(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      StateSpace.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section \<open>State Space Template\<close>
theory StateSpace imports Hoare
begin

record 'g state = "globals"::'g

definition
  upd_globals:: "('g \<Rightarrow> 'g) \<Rightarrow> ('g,'z) state_scheme \<Rightarrow> ('g,'z) state_scheme"
where
  "upd_globals upd s = s\<lparr>globals := upd (globals s)\<rparr>"

record ('g, 'n, 'val) stateSP = "'g state" +
  locals :: "'n \<Rightarrow> 'val"

lemma upd_globals_conv: "upd_globals f = (\<lambda>s. s\<lparr>globals := f (globals s)\<rparr>)"
  by (rule ext) (simp add: upd_globals_def)

end


(*
 * Copyright (C) 2014, National ICT Australia Limited. All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 *
 *  * Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 *
 *  * Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 *
 *  * The name of National ICT Australia Limited nor the names of its
 *    contributors may be used to endorse or promote products derived from
 *    this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
 * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
 * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
 * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *)

theory MoreDivides
imports "~~/src/HOL/Main"
begin

(* FIXME: to Isabelle lib *)
lemma div_mult_le:
  "(a::nat) div b * b \<le> a"
apply(subgoal_tac "a = a div b * b + a mod b")
 apply arith
apply simp
done

(* FIXME: to Isabelle lib *)
lemma mod_le_dividend:
  "m mod n \<le> (m::nat)"
  by (induct m) (auto simp: mod_Suc)

(* diff_mod_le now also in Num_lemmas.ML *)
(* FIXME: to Isabelle lib? *)
lemma diff_mod_le:
  "\<lbrakk> (a::nat) < d; b dvd d \<rbrakk> \<Longrightarrow> a - a mod b \<le> d - b"
apply(subst mult_div_cancel [symmetric])
apply(clarsimp simp: dvd_def)
apply(case_tac "b = 0")
 apply simp
apply(subgoal_tac "a div b \<le> k - 1")
 prefer 2
 apply(subgoal_tac "a div b < k")
  apply(simp add: less_Suc_eq_le [symmetric])
 apply(subgoal_tac "b * (a div b) < b * ((b * k) div b)")
  apply clarsimp
 apply(subst div_mult_self1_is_m)
  apply arith
 apply(rule le_less_trans)
  apply simp
  apply(subst mult.commute)
  apply(rule div_mult_le)
 apply assumption
apply clarsimp
apply(subgoal_tac "b * (a div b) \<le> b * (k - 1)")
 apply(erule le_trans)
 apply(simp add: diff_mult_distrib2)
apply simp
done

lemma int_div_same_is_1 [simp]:
    "0 < a \<Longrightarrow> ((a :: int) div b = a) = (b = 1)"
  by (metis div_by_1 abs_ge_zero abs_of_pos int_div_less_self neq_iff nonneg1_imp_zdiv_pos_iff zabs_less_one_iff)

lemma nat_div_same_is_1 [simp]:
    "a \<noteq> 0 \<Longrightarrow> ((a :: nat) div b = a) = (b = 1)"
  by (metis div_by_0 div_by_1 div_le_dividend div_less_dividend div_self nat_less_le)

lemma int_div_minus_is_minus1 [simp]:
    "a < 0 \<Longrightarrow> ((a :: int) div b = -a) = (b = -1)"
  by (metis div_minus_right equation_minus_iff int_div_same_is_1 neg_0_less_iff_less)

end


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

theory Extract_Conjunct
imports
  "Main"
  "Eisbach_Methods"
begin

section \<open>Extracting conjuncts in the conclusion\<close>

text \<open>
Methods for extracting a conjunct from a nest of conjuncts in the conclusion
of a goal, typically by pattern matching.

When faced with a conclusion which is a big conjunction, it is often the case
that a small number of conjuncts require special attention, while the rest can
be solved easily by @{method clarsimp}, @{method auto} or similar. However,
sometimes the method that would solve the bulk of the conjuncts would put some
of the conjuncts into a more difficult or unsolvable state.

The higher-order methods defined here provide an efficient way to select a
conjunct requiring special treatment, so that it can be dealt with first. Once
all such conjuncts have been removed, the remaining conjuncts can all be solved
together by some automated method.

Each method takes an inner method as an argument, and selects the leftmost
conjunct for which that inner method succeeds. The methods differ according to
what they do with the selected conjunct. See below for more information and
some simple examples.
\<close>

context begin

subsection \<open>Focused conjunct with context\<close>

text \<open>
We define a predicate which allows us to identify a particular sub-tree and its
context within a nest of conjunctions. We express this sub-tree-with-context using
a function which reconstructs the original nest of conjunctions. The context
consists of a list of parent contexts, where each parent context consists of a
sibling sub-tree, and a tag indicating whether the focused sub-tree is on the left
or right. Rebuilding the original tree works from the focused sub-tree up towards
the root of the original structure. This sub-tree-with-context is sometimes known
as a zipper.
\<close>

private fun focus_conj :: "bool \<Rightarrow> bool list \<Rightarrow> bool" where
  "focus_conj current [] = current"
| "focus_conj current (sibling # parents) = focus_conj (current \<and> sibling) parents"

private definition "focus \<equiv> focus_conj"

private definition "tag t P \<equiv> P"
private lemmas focus_defs = focus_def tag_def

private abbreviation "left \<equiv> tag Left"
private abbreviation "right \<equiv> tag Right"

private lemma focus_example:
  "focus C [right B, left D, left E, right A] \<longleftrightarrow> A \<and> ((B \<and> C) \<and> D) \<and> E"
  unfolding focus_defs by auto

subsection \<open>Moving the focus\<close>

text \<open>
We now prove some rules which allow us to switch between focused and unfocused
structures, and to move the focus around. Some versions of these rules carry an
extra conjunct @{term E} outside the structure. Once we find the conjunct we want,
this @{term E} allows to keep track of it while we reassemble the rest of the
original structure.

First, we have rules for going between focused and unfocused structures.
\<close>

private lemma focus_top_iff: "E \<and> focus P [] \<longleftrightarrow> E \<and> P"
  unfolding focus_def by simp

private lemmas to_focus = focus_top_iff[where E=True, simplified, THEN iffD1]
private lemmas from_focusE = focus_top_iff[THEN iffD2]
private lemmas from_focus = from_focusE[where E=True, simplified]

text \<open>
Next, we have rules for moving the focus to and from the left conjunct.
\<close>

private lemma focus_left_iff: "E \<and> focus L (left R # P) \<longleftrightarrow> E \<and> focus (L \<and> R) P"
  unfolding focus_defs by simp

private lemmas focus_left = focus_left_iff[where E=True, simplified, THEN iffD1]
private lemmas unfocusE_left = focus_left_iff[THEN iffD2]
private lemmas unfocus_left = unfocusE_left[where E=True, simplified]

text \<open>
Next, we have rules for moving the focus to and from the right conjunct.
\<close>

private lemma focus_right_iff: "E \<and> focus R (right L # P) \<longleftrightarrow> E \<and> focus (L \<and> R) P"
  unfolding focus_defs using conj_commute by simp

private lemmas focus_right = focus_right_iff[where E=True, simplified, THEN iffD1]
private lemmas unfocusE_right = focus_right_iff[THEN iffD2]
private lemmas unfocus_right = unfocusE_right[where E=True, simplified]

text \<open>
Finally, we have rules for extracting the current focus. The sibling of the
extracted focus becomes the new focus of the remaining structure.
\<close>

private lemma extract_focus_iff: "focus C (tag t S # P) \<longleftrightarrow> (C \<and> focus S P)"
  unfolding focus_defs by (induct P arbitrary: S) auto

private lemmas extract_focus = extract_focus_iff[THEN iffD2]

subsection \<open>Primitive methods for navigating a conjunction\<close>

text \<open>
Using these rules as transitions, we implement a machine which navigates a tree
of conjunctions, searching from left to right for a conjunct for which a given
method will succeed. Once a matching conjunct is found, it is extracted, and the
remaining conjuncts are reassembled.
\<close>

text \<open>From the current focus, move to the leftmost sub-conjunct.\<close>
private method focus_leftmost = (intro focus_left)?

text \<open>Find the furthest ancestor for which the current focus is still on the right.\<close>
private method unfocus_rightmost = (intro unfocus_right)?

text \<open>Move to the immediate-right sibling.\<close>
private method focus_right_sibling = (rule unfocus_left, rule focus_right)

text \<open>Move to the next conjunct in right-to-left ordering.\<close>
private method focus_next_conjunct = (unfocus_rightmost, focus_right_sibling, focus_leftmost)

text \<open>Search from current focus toward the right until we find a matching conjunct.\<close>
private method find_match methods m = (rule extract_focus, m | focus_next_conjunct, find_match m)

text \<open>Search within nest of conjuncts, leaving remaining structure focused.\<close>
private method extract_match methods m = (rule to_focus, focus_leftmost, find_match m)

text \<open>Move all the way out of focus, keeping track of any extracted conjunct.\<close>
private method unfocusE = ((intro unfocusE_right unfocusE_left)?, rule from_focusE)
private method unfocus = ((intro unfocus_right unfocus_left)?, rule from_focus)

subsection \<open>Methods for selecting the leftmost matching conjunct\<close>

text \<open>
See the introduction at the top of this theory for motivation, and below for
some simple examples.
\<close>

text \<open>
Assuming the conclusion of the goal is a nest of conjunctions, method
@{text lift_conjunct} finds the leftmost conjunct for which the given method
succeeds, and moves it to the front of the conjunction in the goal.
\<close>
method lift_conjunct methods m = (extract_match \<open>succeeds \<open>rule conjI, m\<close>\<close>, unfocusE)

text \<open>
Method @{text extract_conjunct} finds the leftmost conjunct for which the
given method succeeds, and splits it into a fresh subgoal, leaving the remaining
conjuncts untouched in the second subgoal. It is equivalent to @{method lift_conjunct}
followed by @{method rule} @{thm conjI}.
\<close>
method extract_conjunct methods m = (extract_match \<open>rule conjI, succeeds m\<close>; unfocus?)

text \<open>
Method @{text apply_conjunct} finds the leftmost conjunct for which the given
method succeeds, leaving any subgoals created by the application of that method,
and a subgoal containing the remaining conjuncts untouched. It is equivalent to
@{method extract_conjunct} followed by the given method, but more efficient.
\<close>
method apply_conjunct methods m = (extract_match \<open>rule conjI, m\<close>; unfocus?)

subsection \<open>Examples\<close>

text \<open>
Given an inner method based on @{method match}, which only succeeds on the desired
conjunct @{term C}, @{method lift_conjunct} moves the conjunct @{term C} to the
front. The body of the @{method match} here is irrelevant, since @{method lift_conjunct}
always discards the effect of the method it is given.
\<close>
lemma "\<lbrakk> A; B; \<lbrakk> A; B; D; E \<rbrakk> \<Longrightarrow> C; D; E \<rbrakk> \<Longrightarrow> A \<and> ((B \<and> C) \<and> D) \<and> E"
  apply (lift_conjunct \<open>match conclusion in C \<Rightarrow> \<open>-\<close>\<close>)
  \<comment> \<open>@{term C} as been moved to the front of the conclusion.\<close>
  apply (match conclusion in \<open>C \<and> A \<and> (B \<and> D) \<and> E\<close> \<Rightarrow> \<open>-\<close>)
  oops

text \<open>
Method @{method extract_conjunct} works similarly, but peels of the matched conjunct
as a separate subgoal. As for @{method lift_conjunct}, the effect of the given method
is discarded, so the body of the @{method match} is irrelevant.
\<close>
lemma "\<lbrakk> A; B; \<lbrakk> A; B; D; E \<rbrakk> \<Longrightarrow> C; D; E \<rbrakk> \<Longrightarrow> A \<and> ((B \<and> C) \<and> D) \<and> E"
  apply (extract_conjunct \<open>match conclusion in C \<Rightarrow> \<open>-\<close>\<close>)
  \<comment> \<open>@{method extract_conjunct} gives us the matched conjunct @{term C} as a separate subgoal.\<close>
   apply (match conclusion in C \<Rightarrow> \<open>-\<close>)
   apply blast
  \<comment> \<open>The other subgoal contains the remaining conjuncts untouched.\<close>
  apply (match conclusion in \<open>A \<and> (B \<and> D) \<and> E\<close> \<Rightarrow> \<open>-\<close>)
  oops

text \<open>
Method @{method apply_conjunct} goes one step further, and applies the given method
to the extracted subgoal.
\<close>
lemma "\<lbrakk> A; B; \<lbrakk> A; B; D; E \<rbrakk> \<Longrightarrow> C; D; E \<rbrakk> \<Longrightarrow> A \<and> ((B \<and> C) \<and> D) \<and> E"
  apply (apply_conjunct \<open>match conclusion in C \<Rightarrow> \<open>match premises in H: _ \<Rightarrow> \<open>rule H\<close>\<close>\<close>)
  \<comment> \<open>We get four subgoals from applying the given method to the matched conjunct @{term C}.\<close>
      apply (match premises in H: A \<Rightarrow> \<open>rule H\<close>)
     apply (match premises in H: B \<Rightarrow> \<open>rule H\<close>)
    apply (match premises in H: D \<Rightarrow> \<open>rule H\<close>)
   apply (match premises in H: E \<Rightarrow> \<open>rule H\<close>)
  \<comment> \<open>The last subgoal contains the remaining conjuncts untouched.\<close>
  apply (match conclusion in \<open>A \<and> (B \<and> D) \<and> E\<close> \<Rightarrow> \<open>-\<close>)
  oops

end

end


section {*I\_kparser\_base*}
theory
  I_kparser_base

imports
  PRJ_08__ENTRY

begin

record ('stack, 'event) parser_step_label =
  rule_lpop :: "'stack list"
  rule_rpop :: "'event list"
  rule_lpush :: "'stack list"
  rule_rpush :: "'event list"

record ('stack, 'event, 'marker) parser =
  parser_nonterms :: "'stack set"
  parser_events :: "'event set"
  parser_initial :: "'stack"
  parser_marking :: "'stack set"
  parser_rules :: "('stack, 'event) parser_step_label set"
  parser_marker :: "('stack, 'event) parser_step_label \<Rightarrow> 'marker"
  parser_bottom :: "'event"

definition valid_parser_step_label :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> ('stack, 'event) parser_step_label
  \<Rightarrow> bool"
  where
    "valid_parser_step_label G e \<equiv>
  (\<exists>k. rule_rpop e \<in> (kPrefix k) `
    {w @ [parser_bottom G] | w.
      set w \<subseteq> parser_events G - {parser_bottom G}})
  \<and> set (rule_rpush e) \<subseteq> parser_events G
  \<and> set (rule_lpop e) \<subseteq> parser_nonterms G
  \<and> set (rule_lpush e) \<subseteq> parser_nonterms G
  \<and> rule_lpop e \<noteq> []
  \<and> rule_lpush e \<noteq> []
  \<and> (\<exists>x. x @ rule_rpush e = rule_rpop e)
  \<and> ((\<exists>x. x @ [parser_bottom G] = rule_rpop e)
      \<longrightarrow> (\<exists>x. x @ [parser_bottom G] = rule_rpush e))"

lemma kPrefix_vs_take: "
  kPrefix k w = take k w"
  apply(simp add: kPrefix_def)
  done

definition valid_parser :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> bool"
  where
    "valid_parser G \<equiv>
  finite (parser_events G)
  \<and> finite (parser_nonterms G)
  \<and> parser_initial G \<in> parser_nonterms G
  \<and> parser_marking G \<subseteq> parser_nonterms G
  \<and> finite (parser_rules G)
  \<and> (\<forall>e \<in> parser_rules G.
      valid_parser_step_label G e)
  \<and> parser_bottom G \<in> parser_events G"

definition parser_step_labels :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> ('stack, 'event) parser_step_label set"
  where
    "parser_step_labels G \<equiv>
  parser_rules G"

datatype ('stack, 'event) parser_destinations =
  state "'stack"
  | rule "('stack, 'event) parser_step_label"

definition parser_destinations :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> ('stack, 'event) parser_destinations set"
  where
    "parser_destinations G \<equiv>
  state ` (parser_nonterms G)
  \<union> rule ` (parser_rules G)"

definition parser_markers :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list set"
  where
    "parser_markers G \<equiv>
  {w. set w \<subseteq> parser_events G}"

definition parser_schedulers :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list set"
  where
    "parser_schedulers G \<equiv>
  {w. \<exists>v.
    set v \<subseteq> parser_events G
    \<and> parser_bottom G \<notin> set v
    \<and> w = v @ [parser_bottom G]}"

definition parser_fixed_schedulers :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list set"
  where
    "parser_fixed_schedulers G \<equiv>
  prefix_closure (parser_schedulers G)"

definition parser_unfixed_schedulers :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list set"
  where
    "parser_unfixed_schedulers G \<equiv>
  suffix_closure (parser_schedulers G)"

definition parser_scheduler_fragments :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list set"
  where
    "parser_scheduler_fragments G \<equiv>
  {w. set w \<subseteq> parser_events G \<and> parser_bottom G \<notin> set w}"

definition parser_no_top_rules :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> bool"
  where
    "parser_no_top_rules G \<equiv>
  \<forall>e \<in> parser_rules G. rule_rpush e = []"

definition parser_observes_input_terminator :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> bool"
  where
    "parser_observes_input_terminator G \<equiv>
  \<exists>e \<in> parser_rules G. parser_bottom G \<in> set (rule_rpop e)"

definition parser_not_observes_input_terminator :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> bool"
  where
    "parser_not_observes_input_terminator G \<equiv>
  \<forall>e \<in> parser_rules G. parser_bottom G \<notin> set (rule_rpush e)"

definition parser_no_access_final_with_read :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> bool"
  where
    "parser_no_access_final_with_read G \<equiv>
  \<forall>e \<in> parser_rules G. \<forall>a.
  rule_rpop e = [a]
  \<and> rule_rpush e = []
  \<and> last (rule_lpush e) \<in> parser_marking G
  \<longrightarrow> False"

definition parser_no_leave_final_with_empty_step :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> bool"
  where
    "parser_no_leave_final_with_empty_step G \<equiv>
  \<forall>q \<in> parser_marking G.
  \<forall>e \<in> parser_rules G.
  last (rule_lpop e) = q
  \<and> rule_rpop e \<in> {[parser_bottom G], []}
  \<longrightarrow> last (rule_lpush e) \<in> parser_marking G"

primrec tau :: "
  ('a \<Rightarrow> 'b option option)
  \<Rightarrow> 'a option list
  \<Rightarrow> 'b option list"
  where
    "tau f [] = []"
  | "tau f (a # w) =
  (case a
  of None \<Rightarrow> []
  | Some a' \<Rightarrow> (case (f a')
                of None \<Rightarrow> []
                | Some a'' \<Rightarrow> (case a''
                              of None \<Rightarrow> []
                              | Some a''' \<Rightarrow> [Some a'''])))
  @ tau f w"

lemma tau_select: "
  x \<in> set (tau f w)
  \<Longrightarrow> (\<exists>y. x \<in> set (tau f [y]) \<and> y \<in> set w)"
  apply(induct w)
   apply(clarsimp)
  apply(rename_tac a w)(*strict*)
  apply(clarsimp)
  apply(erule disjE)
   apply(rename_tac a w)(*strict*)
   apply(clarsimp)
   apply(rename_tac w uu_ uua_)(*strict*)
   apply(rename_tac x1 x2)
   apply(rename_tac w x1 x2)(*strict*)
   apply(rule_tac
      x="Some x2"
      in exI)
   apply(clarsimp)
  apply(rename_tac a w)(*strict*)
  apply(clarsimp)
  apply(rename_tac a w uu_ uua_)(*strict*)
  apply(rename_tac x1 x2)
  apply(rename_tac a w x1 x2)(*strict*)
  apply(rule_tac
      x="Some x2"
      in exI)
  apply(clarsimp)
  done

definition valid_bounded_parser :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> nat
  \<Rightarrow> bool"
  where
    "valid_bounded_parser G k \<equiv>
  valid_parser G
  \<and> (\<forall>e \<in> parser_rules G. length (rule_rpop e) \<le> k)"

lemma valid_parser_initial_in_nonterms: "
  valid_parser P
  \<Longrightarrow> parser_initial P \<in> parser_nonterms P"
  apply(simp add: valid_parser_def)
  done

lemma valid_parser_bottom_in_parser_events: "
  valid_parser P
  \<Longrightarrow> parser_bottom P \<in> parser_events P"
  apply(simp add: valid_parser_def)
  done

lemma valid_parser_step_label_not_parser_bottom_random_insertion: "
  valid_parser_step_label G e
  \<Longrightarrow> (\<exists>x. x@[parser_bottom G]=rule_rpush e) \<longrightarrow> (\<exists>x. x@[parser_bottom G]=rule_rpop e)"
  apply(simp add: valid_parser_step_label_def)
  apply(erule conjE)+
  apply(rule impI)
  apply(erule exE)+
  apply(rename_tac k x xa)(*strict*)
  apply(rule_tac
      x="x@xa"
      in exI)
  apply(force)
  done

lemma valid_parser_step_label_also_req_for_rpush: "
  valid_parser_step_label G e
  \<Longrightarrow> (\<exists>k. rule_rpush e \<in> ((kPrefix k) ` ({w@[parser_bottom G]|w. set w\<subseteq> (parser_events G)-{parser_bottom G}})))"
  apply(simp add: valid_parser_step_label_def)
  apply(clarsimp)
  apply(rename_tac k w xa)(*strict*)
  apply(case_tac e)
  apply(rename_tac k w xa rule_lpopa rule_rpopa rule_lpusha rule_rpusha)(*strict*)
  apply(clarsimp)
  apply(rename_tac k w xa rule_lpop rule_lpush rule_rpush)(*strict*)
  apply(simp add: kPrefix_def)
  apply(case_tac "k-length w>0")
   apply(rename_tac k w xa rule_lpop rule_lpush rule_rpush)(*strict*)
   apply(clarsimp)
   apply(rename_tac k xa rule_lpop rule_lpush x)(*strict*)
   apply(rule_tac
      x="Suc (length x)"
      in exI)
   apply(rule inMap)
   apply(clarsimp)
   apply(rule_tac
      x="x@[parser_bottom G]"
      in exI)
   apply(clarsimp)
   apply(simp add: kPrefix_def)
  apply(rename_tac k w xa rule_lpop rule_lpush rule_rpush)(*strict*)
  apply(clarsimp)
  apply(case_tac "rule_rpush")
   apply(rename_tac k w xa rule_lpop rule_lpush rule_rpush)(*strict*)
   apply(clarsimp)
   apply(rename_tac k w rule_lpop rule_lpush)(*strict*)
   apply(rule_tac
      x="0"
      in exI)
   apply(rule inMap)
   apply(rule_tac
      x="[parser_bottom G]"
      in bexI)
    apply(rename_tac k w rule_lpop rule_lpush)(*strict*)
    apply(simp add: kPrefix_def)
   apply(rename_tac k w rule_lpop rule_lpush)(*strict*)
   apply(clarsimp)
  apply(rename_tac k w xa rule_lpop rule_lpush rule_rpush a list)(*strict*)
  apply(subgoal_tac "\<exists>w' x'. rule_rpush = w' @ [x']")
   apply(rename_tac k w xa rule_lpop rule_lpush rule_rpush a list)(*strict*)
   prefer 2
   apply(rule NonEmptyListHasTailElem)
   apply(force)
  apply(rename_tac k w xa rule_lpop rule_lpush rule_rpush a list)(*strict*)
  apply(thin_tac "rule_rpush = a # list")
  apply(clarsimp)
  apply(rename_tac k w xa rule_lpop rule_lpush w' x')(*strict*)
  apply(case_tac "x'=parser_bottom G")
   apply(rename_tac k w xa rule_lpop rule_lpush w' x')(*strict*)
   apply(clarsimp)
   apply(rename_tac k w xa rule_lpop rule_lpush w')(*strict*)
   apply(rule_tac
      x="Suc(length w')"
      in exI)
   apply(rule inMap)
   apply(clarsimp)
   apply(rule_tac
      x="w' @ [parser_bottom G]"
      in exI)
   apply(clarsimp)
   apply(simp add: kPrefix_def)
   apply(rule_tac
      B="set w"
      in subset_trans)
    apply(rename_tac k w xa rule_lpop rule_lpush w')(*strict*)
    apply(rule_tac
      B="set (take k w)"
      in subset_trans)
     apply(rename_tac k w xa rule_lpop rule_lpush w')(*strict*)
     apply(rule_tac
      B="set (xa @ w' @ [parser_bottom G])"
      in subset_trans)
      apply(rename_tac k w xa rule_lpop rule_lpush w')(*strict*)
      apply(rule set_bi_append)
     apply(rename_tac k w xa rule_lpop rule_lpush w')(*strict*)
     apply(force)
    apply(rename_tac k w xa rule_lpop rule_lpush w')(*strict*)
    apply(rule set_take_subset)
   apply(rename_tac k w xa rule_lpop rule_lpush w')(*strict*)
   apply(force)
  apply(rename_tac k w xa rule_lpop rule_lpush w' x')(*strict*)
  apply(clarsimp)
  apply(rule_tac
      x="Suc(length w')"
      in exI)
  apply(rule inMap)
  apply(clarsimp)
  apply(rule_tac
      x="w' @ [x'] @ [parser_bottom G]"
      in exI)
  apply(clarsimp)
  apply(simp add: kPrefix_def)
  apply(rule_tac
      B="set w"
      in subset_trans)
   apply(rename_tac k w xa rule_lpop rule_lpush w' x')(*strict*)
   apply(rule_tac
      B="set (take k w)"
      in subset_trans)
    apply(rename_tac k w xa rule_lpop rule_lpush w' x')(*strict*)
    apply(rule_tac
      B="set (xa @ w' @ [x'])"
      in subset_trans)
     apply(rename_tac k w xa rule_lpop rule_lpush w' x')(*strict*)
     apply(rule set_bi_append)
    apply(rename_tac k w xa rule_lpop rule_lpush w' x')(*strict*)
    apply(force)
   apply(rename_tac k w xa rule_lpop rule_lpush w' x')(*strict*)
   apply(rule set_take_subset)
  apply(rename_tac k w xa rule_lpop rule_lpush w' x')(*strict*)
  apply(force)
  done

lemma tau_append_commutes: "
  tau f (w@v) = tau f w @ (tau f v)"
  apply(induct w)
   apply(clarsimp)
  apply(rename_tac a w)(*strict*)
  apply(clarsimp)
  done

primrec parser_fixed_input_length_recN :: "
  (('stack, 'event) parser_step_label, 'abstr_parser_conf)derivation
  \<Rightarrow> nat
  \<Rightarrow> nat"
  where
    "parser_fixed_input_length_recN d 0 = 0"
  | "parser_fixed_input_length_recN d (Suc n) =
    (case d (Suc n) of
      Some (pair (Some e) c) \<Rightarrow>
          max
            (parser_fixed_input_length_recN d n)
            (length (rule_rpop e))
          - (length (rule_rpop e) - length (rule_rpush e))
    | _ \<Rightarrow> parser_fixed_input_length_recN d n)"

definition parser_fixed_input_length_foldl :: "
  (('stack, 'event) parser_step_label, 'abstr_parser_conf)derivation
  \<Rightarrow> nat
  \<Rightarrow> nat"
  where
    "parser_fixed_input_length_foldl d n \<equiv>
  foldl
    (\<lambda>x s. (case s of [a, b] \<Rightarrow> (max x a) - (a - b)))
    0
    (map
      (\<lambda>n.
        case d n of
          Some (pair (Some e) c) \<Rightarrow>
            [length (rule_rpop e), length (rule_rpush e)])
      (nat_seq (Suc 0) n))"

primrec parser_fixed_input_length_rec1 :: "
  (('stack, 'event) parser_step_label, 'abstr_parser_conf)derivation
  \<Rightarrow> nat
  \<Rightarrow> nat"
  where
    "parser_fixed_input_length_rec1 d 0 = 0"
  | "(parser_fixed_input_length_rec1 d (Suc n)) =
    (case d (Suc n) of
      Some (pair (Some e) c) \<Rightarrow>
        (case rule_rpop e of
            [] \<Rightarrow> parser_fixed_input_length_rec1 d n
            | _ \<Rightarrow> length (rule_rpush e))
      | _ \<Rightarrow> parser_fixed_input_length_rec1 d n)"

(*
  The unmarked language should be contained in the prefixclosure of the set of words which (if the parser is started with one of them) can touch every every DT_symbol.
  Furthermore, an element of this prefixclosure is only contained, if

  r·s in unmarked_language
  \<longleftrightarrow> \<exists>d t. d start with r·s·t·$ and ends with s·t·$ where s (and (if t=\<lambda>) possibly $) has been seen and t has not been seen
  \<longleftrightarrow> \<exists>d. d start with r·s·$ and ends with s·$ where s (and possibly $) has been seen

  Note, the translation of a parser into a topfree parser should preserve marked and unmarked language.
  Therefore the interpretation is reasonable.

  Example:
  derivation: q0 | ab$ \<Rightarrow> (q0, ab$, q1, $) \<Rightarrow> q1|$
  unmarked_language_element: i=0: \<lambda>
  unmarked_language_element: i=1: ab
  derivation: q0 | ab$ \<Rightarrow> (q0, ab, q1, b) \<Rightarrow> q1|b$
  unmarked_language_element: i=0: \<lambda>
  unmarked_language_element: i=1: ab
  derivation: q0 | ab$ \<Rightarrow> (q0, a, q1, \<lambda>) \<Rightarrow> q1|b$
  unmarked_language_element: i=0: \<lambda>
  unmarked_language_element: i=1: a
*)

lemma parser_inst_AX_empty_fixed_scheduler_in_fixed_schedulers: "
  \<forall>G. valid_parser G \<longrightarrow> [] \<in> parser_fixed_schedulers G"
  apply(simp add: parser_fixed_schedulers_def prefix_closure_def prefix_def parser_schedulers_def)
  apply(clarsimp)
  apply(rename_tac G)(*strict*)
  apply(rule_tac
      x="[]"
      in exI)
  apply(force)
  done

lemma parser_inst_AX_empty_scheduler_fragment_in_scheduler_fragments: "
  \<forall>G. valid_parser G \<longrightarrow> [] \<in> parser_scheduler_fragments G"
  apply(simp add: parser_scheduler_fragments_def)
  done

lemma parser_inst_AX_join_scheduler_fragments_closed : "
  (\<forall>G. valid_parser G \<longrightarrow> (\<forall>sE1. sE1 \<in> parser_scheduler_fragments G \<longrightarrow> (\<forall>sE2. sE2 \<in> parser_scheduler_fragments G \<longrightarrow> sE1 @ sE2 \<in> parser_scheduler_fragments G)))"
  apply(simp add: parser_scheduler_fragments_def)
  done

lemma parser_inst_AX_join_scheduler_fragments_foldl_split: "
  (\<forall>w v. foldl (@) (foldl (@) [] w) v = foldl (@) [] w @ foldl (@) [] v)"
  apply (metis concat_conv_foldl foldl_conv_concat)
  done

lemma parser_inst_AX_foldl_join_scheduler_fragments : "
  (\<forall>G. valid_parser G \<longrightarrow> (\<forall>sE. sE \<in> parser_scheduler_fragments G \<longrightarrow> (\<forall>w. set w \<subseteq> parser_scheduler_fragments G \<longrightarrow> foldl (@) sE w = sE @ foldl (@) [] w)))"
  apply(clarsimp)
  apply(rename_tac G sE w)(*strict*)
  apply (metis concat_conv_foldl foldl_conv_concat)
  done

lemma parser_inst_AX_extend_unfixed_scheduler_unfixed_scheduler_right_quotient_empty: "
  (\<forall>G. valid_parser G \<longrightarrow> (\<forall>sUF. sUF \<in> parser_unfixed_schedulers G \<longrightarrow> the (right_quotient_word sUF []) = sUF))"
  apply(simp add: right_quotient_word_def)
  done

lemma parser_inst_AX_unfixed_scheduler_right_quotient_all: "
  (\<forall>G. valid_parser G \<longrightarrow> (\<forall>sUF. sUF \<in> parser_unfixed_schedulers G \<longrightarrow> right_quotient_word sUF sUF = Some []))"
  apply(clarsimp)
  apply(rename_tac G sUF)(*strict*)
  apply(simp add: right_quotient_word_def)
  done

lemma parser_inst_AX_empty_unfixed_scheduler_in_unfixed_schedulers: "
  (\<forall>G. valid_parser G \<longrightarrow> [] \<in> parser_unfixed_schedulers G)"
  apply(simp add: parser_unfixed_schedulers_def suffix_closure_def suffix_def parser_schedulers_def)
  apply(clarsimp)
  apply(rename_tac G)(*strict*)
  apply(rule_tac
      x="[]"
      in exI)
  apply(force)
  done

lemma parser_inst_AX_extend_unfixed_scheduler_closed: "
  (\<forall>G. valid_parser G \<longrightarrow> (\<forall>sE. sE \<in> parser_scheduler_fragments G \<longrightarrow> (\<forall>sUF. sUF \<in> parser_unfixed_schedulers G \<longrightarrow> sUF \<sqsupseteq> [parser_bottom G] \<longrightarrow> sE @ sUF \<in> parser_unfixed_schedulers G)))"
  apply(simp add: suffix_def parser_unfixed_schedulers_def parser_scheduler_fragments_def parser_schedulers_def suffix_closure_def)
  apply(clarsimp)
  apply(rename_tac G sE c ca)(*strict*)
  apply(rule_tac
      x="sE@ca@[parser_bottom G]"
      in exI)
  apply(clarsimp)
  done

lemma parser_inst_AX_extend_scheduler_closed: "
  (\<forall>G. valid_parser G \<longrightarrow> (\<forall>sE. sE \<in> parser_scheduler_fragments G \<longrightarrow> (\<forall>s. s \<in> parser_schedulers G \<longrightarrow> sE @ s \<in> parser_schedulers G)))"
  apply(clarsimp)
  apply(rename_tac G sE s)(*strict*)
  apply(simp add: parser_schedulers_def parser_scheduler_fragments_def)
  apply(clarsimp)
  done

lemma parser_inst_AX_extend_unfixed_scheduler_preserves_unfixed_scheduler_extendable: "
  (\<forall>G. valid_parser G \<longrightarrow> (\<forall>sUF. sUF \<sqsupseteq> [parser_bottom G] \<longrightarrow> (\<forall>sE. (sE @ sUF) \<sqsupseteq> [parser_bottom G])))"
  apply(clarsimp)
  apply(rename_tac G sUF sE)(*strict*)
  apply(simp add: suffix_def)
  apply(force)
  done

lemma parser_inst_AX_empty_scheduler_in_schedulers: "
  (\<forall>G. valid_parser G \<longrightarrow> [parser_bottom G] \<in> parser_schedulers G)"
  apply(simp add: parser_schedulers_def)
  done

lemma parser_inst_AX_join_fixed_scheduler_unfixed_scheduler_closed: "
  (\<forall>G. valid_parser G \<longrightarrow> (\<forall>sF. sF \<in> parser_fixed_schedulers G \<longrightarrow> (\<forall>sUF. sUF \<in> parser_unfixed_schedulers G \<longrightarrow> (\<not> sF \<sqsupseteq> [parser_bottom G]) = sUF \<sqsupseteq> [parser_bottom G] \<longrightarrow> sF @ sUF \<in> parser_schedulers G)))"
  apply(clarsimp)
  apply(rename_tac G sF sUF)(*strict*)
  apply(simp add: suffix_def)
  apply(simp add: parser_schedulers_def parser_fixed_schedulers_def parser_unfixed_schedulers_def prefix_closure_def prefix_def suffix_closure_def suffix_def)
  apply(clarsimp)
  apply(rename_tac G sF sUF vb c vc ca)(*strict*)
  apply(case_tac sUF)
   apply(rename_tac G sF sUF vb c vc ca)(*strict*)
   apply(clarsimp)
   apply(rename_tac G vb c vc cb)(*strict*)
   apply(case_tac c)
    apply(rename_tac G vb c vc cb)(*strict*)
    apply(clarsimp)
   apply(rename_tac G vb c vc cb a list)(*strict*)
   apply(subgoal_tac "\<exists>w' x'. c = w' @ [x']")
    apply(rename_tac G vb c vc cb a list)(*strict*)
    prefer 2
    apply(rule NonEmptyListHasTailElem)
    apply(force)
   apply(rename_tac G vb c vc cb a list)(*strict*)
   apply(thin_tac "c = a # list")
   apply(clarsimp)
  apply(rename_tac G sF sUF vb c vc ca a list)(*strict*)
  apply(subgoal_tac "\<exists>w' x'. sUF = w' @ [x']")
   apply(rename_tac G sF sUF vb c vc ca a list)(*strict*)
   prefer 2
   apply(rule NonEmptyListHasTailElem)
   apply(force)
  apply(rename_tac G sF sUF vb c vc ca a list)(*strict*)
  apply(thin_tac "sUF = a # list")
  apply(clarsimp)
  apply(rename_tac G sF vb c ca w')(*strict*)
  apply(case_tac c)
   apply(rename_tac G sF vb c ca w')(*strict*)
   apply(clarsimp)
  apply(rename_tac G sF vb c ca w' a list)(*strict*)
  apply(subgoal_tac "\<exists>w' x'. c = w' @ [x']")
   apply(rename_tac G sF vb c ca w' a list)(*strict*)
   prefer 2
   apply(rule NonEmptyListHasTailElem)
   apply(force)
  apply(rename_tac G sF vb c ca w' a list)(*strict*)
  apply(thin_tac "c = a # list")
  apply(clarsimp)
  done

lemma valid_bounded_parser_vs_valid_parser: "
  valid_bounded_parser G k
  \<Longrightarrow> valid_parser G"
  apply(simp add: valid_bounded_parser_def)
  done

lemma parser1X_inst_AX_empty_fixed_scheduler_in_fixed_schedulers: "
  \<forall>G. valid_bounded_parser G (Suc 0) \<longrightarrow> [] \<in> parser_fixed_schedulers G"
  apply(metis valid_bounded_parser_vs_valid_parser parser_inst_AX_empty_fixed_scheduler_in_fixed_schedulers)
  done

lemma parser_inst_AX_fixed_scheduler_extendable_vs_unfixed_scheduler_extendable: "
  (\<forall>G. valid_parser G \<longrightarrow> (\<forall>sF. sF \<in> parser_fixed_schedulers G \<longrightarrow> (\<forall>sUF. sUF \<in> parser_unfixed_schedulers G \<longrightarrow> sF @ sUF \<in> parser_schedulers G \<longrightarrow> (\<not> sF \<sqsupseteq> [parser_bottom G]) = sUF \<sqsupseteq> [parser_bottom G])))"
  apply(clarsimp)
  apply(rename_tac G sF sUF)(*strict*)
  apply(simp add: suffix_closure_def prefix_closure_def prefix_def suffix_def parser_schedulers_def parser_fixed_schedulers_def parser_unfixed_schedulers_def)
  apply(clarsimp)
  apply(rename_tac G sF sUF vb vc c vd ca)(*strict*)
  apply(case_tac sF)
   apply(rename_tac G sF sUF vb vc c vd ca)(*strict*)
   apply(clarsimp)
  apply(rename_tac G sF sUF vb vc c vd ca a list)(*strict*)
  apply(subgoal_tac "\<exists>w' x'. sF = w' @ [x']")
   apply(rename_tac G sF sUF vb vc c vd ca a list)(*strict*)
   prefer 2
   apply(rule NonEmptyListHasTailElem)
   apply(force)
  apply(rename_tac G sF sUF vb vc c vd ca a list)(*strict*)
  apply(thin_tac "sF = a # list")
  apply(clarsimp)
  apply(rename_tac G sUF vb vc c vd ca w' x')(*strict*)
  apply(case_tac c)
   apply(rename_tac G sUF vb vc c vd ca w' x')(*strict*)
   apply(clarsimp)
  apply(rename_tac G sUF vb vc c vd ca w' x' a list)(*strict*)
  apply(subgoal_tac "\<exists>w' x'. c = w' @ [x']")
   apply(rename_tac G sUF vb vc c vd ca w' x' a list)(*strict*)
   prefer 2
   apply(rule NonEmptyListHasTailElem)
   apply(force)
  apply(rename_tac G sUF vb vc c vd ca w' x' a list)(*strict*)
  apply(thin_tac "c = a # list")
  apply(clarsimp)
  apply(rename_tac G sUF vb vd ca w' x' w'a)(*strict*)
  apply(metis last_append last_snoc snoc_eq_iff_butlast)
  done

lemma valid_parser_rules_rhs_gets_shorter: "
  valid_parser P
  \<Longrightarrow> e \<in> parser_rules P
  \<Longrightarrow> length (rule_rpush e) \<le> length (rule_rpop e)"
  apply(simp add: valid_parser_def)
  apply(clarsimp)
  apply(erule_tac
      x="e"
      in ballE)
   apply(auto)
  apply(simp add: valid_parser_step_label_def)
  apply(clarsimp)
  apply(rename_tac k w xa)(*strict*)
  apply(rule_tac
      t="kPrefix k (w @ [parser_bottom P])"
      and s="xa @ rule_rpush e"
      in ssubst)
   apply(rename_tac k w xa)(*strict*)
   apply(force)
  apply(rename_tac k w xa)(*strict*)
  apply(simp (no_asm_use))
  done

definition parser_empty_fixed_scheduler :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list"
  where
    "parser_empty_fixed_scheduler G \<equiv>
  []"
declare parser_empty_fixed_scheduler_def [simp add]

definition parser_empty_unfixed_scheduler :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list"
  where
    "parser_empty_unfixed_scheduler G \<equiv>
  []"
declare parser_empty_unfixed_scheduler_def [simp add]

definition parser_fixed_scheduler_extendable :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list
  \<Rightarrow> bool"
  where
    "parser_fixed_scheduler_extendable G w \<equiv>
  \<not> suffix w [parser_bottom G]"
declare parser_fixed_scheduler_extendable_def [simp add]

definition parser_unfixed_scheduler_extendable :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list
  \<Rightarrow> bool"
  where
    "parser_unfixed_scheduler_extendable G w \<equiv>
  suffix w [parser_bottom G]"
declare parser_unfixed_scheduler_extendable_def [simp add]

definition parser_empty_history :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list"
  where
    "parser_empty_history G \<equiv>
  []"
declare parser_empty_history_def [simp add]

definition parser_empty_history_fragment :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list"
  where
    "parser_empty_history_fragment G \<equiv>
  []"
declare parser_empty_history_fragment_def [simp add]

definition parser_empty_scheduler :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list"
  where
    "parser_empty_scheduler G \<equiv>
  [parser_bottom G]"
declare parser_empty_scheduler_def [simp add]

definition parser_empty_scheduler_fragment :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list"
  where
    "parser_empty_scheduler_fragment G \<equiv>
  []"
declare parser_empty_scheduler_fragment_def [simp add]

lemma parser_inst_ATS_SchedF_Basic_axioms: "
  ATS_SchedF_Basic_axioms valid_parser parser_fixed_schedulers
     parser_empty_fixed_scheduler"
  apply(simp add: ATS_SchedF_Basic_axioms_def)
  apply(simp add: parser_inst_AX_empty_fixed_scheduler_in_fixed_schedulers )
  done

lemma parser_inst_ATS_Scheduler_Fragment_axioms: "
  ATS_Scheduler_Fragment_axioms valid_parser parser_scheduler_fragments
     parser_empty_scheduler_fragment (@)"
  apply(simp add: ATS_Scheduler_Fragment_axioms_def)
  apply(simp add: parser_inst_AX_join_scheduler_fragments_closed parser_inst_AX_join_scheduler_fragments_foldl_split parser_inst_AX_empty_scheduler_fragment_in_scheduler_fragments )
  apply(simp add: parser_inst_AX_foldl_join_scheduler_fragments)
  done

lemma parser_inst_ATS_SchedUF_Basic_axioms: "
  ATS_SchedUF_Basic_axioms valid_parser parser_scheduler_fragments
     parser_empty_scheduler_fragment parser_unfixed_schedulers
     parser_empty_unfixed_scheduler right_quotient_word (@)
     parser_unfixed_scheduler_extendable"
  apply(simp add: ATS_SchedUF_Basic_axioms_def)
  apply(simp add: parser_inst_AX_extend_unfixed_scheduler_preserves_unfixed_scheduler_extendable parser_inst_AX_extend_unfixed_scheduler_unfixed_scheduler_right_quotient_empty parser_inst_AX_unfixed_scheduler_right_quotient_all parser_inst_AX_empty_unfixed_scheduler_in_unfixed_schedulers parser_inst_AX_extend_unfixed_scheduler_closed )
  done

lemma parser_inst_ATS_Sched_Basic_axioms: "
  ATS_Sched_Basic_axioms valid_parser parser_fixed_schedulers
     parser_fixed_scheduler_extendable parser_unfixed_schedulers
     parser_unfixed_scheduler_extendable parser_schedulers (@)"
  apply(simp add: ATS_Sched_Basic_axioms_def)
  apply(simp add: parser_inst_AX_join_fixed_scheduler_unfixed_scheduler_closed )
  done

lemmas parser_interpretations =
  parser_inst_ATS_SchedF_Basic_axioms
  parser_inst_ATS_Sched_Basic_axioms
  parser_inst_ATS_Scheduler_Fragment_axioms
  parser_inst_ATS_SchedUF_Basic_axioms

lemma PARSER_rule_rpop_in_parser_events: "
  valid_parser G
  \<Longrightarrow> e \<in> parser_rules G
  \<Longrightarrow> set (rule_rpop e) \<subseteq> parser_events G"
  apply(simp add: valid_parser_def valid_parser_step_label_def kPrefix_def)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(erule_tac
      x="e"
      in ballE)
   apply(rename_tac x)(*strict*)
   prefer 2
   apply(force)
  apply(rename_tac x)(*strict*)
  apply(clarsimp)
  apply(rename_tac x k w xb)(*strict*)
  apply(simp add: valid_parser_def valid_parser_step_label_def kPrefix_def)
  apply(erule disjE)
   apply(rename_tac x k w xb)(*strict*)
   apply(rule_tac
      A="set w"
      in set_mp)
    apply(rename_tac x k w xb)(*strict*)
    apply(force)
   apply(rename_tac x k w xb)(*strict*)
   apply (metis in_set_takeD)
  apply(rename_tac x k w xb)(*strict*)
  apply(case_tac "k-length w")
   apply(rename_tac x k w xb)(*strict*)
   apply(clarsimp)
  apply(rename_tac x k w xb nat)(*strict*)
  apply(clarsimp)
  done

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Representable and corepresentable functors\<close>
theory CZH_UCAT_Representable
  imports
    CZH_Elementary_Categories.CZH_ECAT_Yoneda
    CZH_UCAT_Pointed
    CZH_UCAT_Limit
begin

subsection\<open>Representable and corepresentable functors\<close>

subsubsection\<open>Definitions and elementary properties\<close>

text\<open>
See Chapter III-2 in \<^cite>\<open>"mac_lane_categories_2010"\<close>
or Section 2.1 in \<^cite>\<open>"riehl_category_2016"\<close>.
\<close>

definition cat_representation :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  where "cat_representation \<alpha> \<FF> c \<psi> \<longleftrightarrow>
    c \<in>\<^sub>\<circ> \<FF>\<lparr>HomDom\<rparr>\<lparr>Obj\<rparr> \<and>
    \<psi> : Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<FF>\<lparr>HomDom\<rparr>(c,-) \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o \<FF> : \<FF>\<lparr>HomDom\<rparr> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"

definition cat_corepresentation :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  where "cat_corepresentation \<alpha> \<FF> c \<psi> \<longleftrightarrow>
    c \<in>\<^sub>\<circ> \<FF>\<lparr>HomDom\<rparr>\<lparr>Obj\<rparr> \<and>
    \<psi> : Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>op_cat (\<FF>\<lparr>HomDom\<rparr>)(-,c) \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o \<FF> : \<FF>\<lparr>HomDom\<rparr> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"

text\<open>Rules.\<close>

context
  fixes \<alpha> \<CC> \<FF>
  assumes \<FF>: "\<FF> : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
begin

interpretation \<FF>: is_functor \<alpha> \<CC> \<open>cat_Set \<alpha>\<close> \<FF> by (rule \<FF>)

mk_ide rf cat_representation_def[where \<alpha>=\<alpha> and \<FF>=\<FF>, unfolded cat_cs_simps]
  |intro cat_representationI|
  |dest cat_representationD'|
  |elim cat_representationE'|

end

lemmas cat_representationD[dest] = cat_representationD'[rotated]
  and  cat_representationE[elim] = cat_representationE'[rotated]

lemma cat_corepresentationI:
  assumes "category \<alpha> \<CC>"
    and "\<FF> : op_cat \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
    and "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "\<psi> : Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<CC>(-,c) \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o \<FF> : op_cat \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
  shows "cat_corepresentation \<alpha> \<FF> c \<psi>"
proof-
  interpret category \<alpha> \<CC> by (rule assms(1))
  interpret \<FF>: is_functor \<alpha> \<open>op_cat \<CC>\<close> \<open>cat_Set \<alpha>\<close> \<FF> by (rule assms(2))
  note [cat_op_simps] = \<FF>.HomDom.cat_op_cat_cf_Hom_snd[
      symmetric, unfolded cat_op_simps, OF assms(3)
      ]
  show ?thesis
    unfolding cat_corepresentation_def
    by (intro conjI, unfold cat_cs_simps cat_op_simps; intro assms)
qed

lemma cat_corepresentationD:
  assumes "cat_corepresentation \<alpha> \<FF> c \<psi>"
    and "category \<alpha> \<CC>"
    and "\<FF> : op_cat \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
  shows "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "\<psi> : Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<CC>(-,c) \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o \<FF> : op_cat \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
proof-
  interpret category \<alpha> \<CC> by (rule assms(2))
  interpret \<FF>: is_functor \<alpha> \<open>op_cat \<CC>\<close> \<open>cat_Set \<alpha>\<close> \<FF> by (rule assms(3))
  note c\<psi> = cat_corepresentation_def[
      THEN iffD1, OF assms(1), unfolded cat_cs_simps cat_op_simps
      ]
  from c\<psi>(1) show c: "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" by auto
  note [cat_op_simps] = \<FF>.HomDom.cat_op_cat_cf_Hom_snd[
      symmetric, unfolded cat_op_simps, OF c
      ]
  show "\<psi> : Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<CC>(-,c) \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o \<FF> : op_cat \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
    by (rule conjunct2[OF c\<psi>, unfolded cat_op_simps])
qed

lemma cat_corepresentationE:
  assumes "cat_corepresentation \<alpha> \<FF> c \<psi>"
    and "category \<alpha> \<CC>"
    and "\<FF> : op_cat \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
  obtains "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "\<psi> : Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<CC>(-,c) \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o \<FF> : op_cat \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
  by (simp add: cat_corepresentationD[OF assms])

subsubsection\<open>Representable functors and universal arrows\<close>

lemma universal_arrow_of_if_cat_representation:
  \<comment>\<open>See Proposition 2 in Chapter III-2 in \cite{mac_lane_categories_2010}.\<close>
  assumes "\<KK> : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
    and "cat_representation \<alpha> \<KK> r \<psi>"
    and "\<aa> \<in>\<^sub>\<circ> cat_Set \<alpha>\<lparr>Obj\<rparr>"
  shows "universal_arrow_of
    \<KK> (set {\<aa>}) r (ntcf_paa \<aa> (\<KK>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>) (\<psi>\<lparr>NTMap\<rparr>\<lparr>r\<rparr>\<lparr>ArrVal\<rparr>\<lparr>\<CC>\<lparr>CId\<rparr>\<lparr>r\<rparr>\<rparr>))"
proof-
  note r\<psi> = cat_representationD[OF assms(2,1)]
  interpret \<KK>: is_functor \<alpha> \<CC> \<open>cat_Set \<alpha>\<close> \<KK> by (rule assms(1))
  interpret \<psi>: is_iso_ntcf \<alpha> \<CC> \<open>cat_Set \<alpha>\<close> \<open>Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<CC>(r,-)\<close> \<KK> \<psi>
    by (rule r\<psi>(2))
  from assms(3) have set_\<aa>: "set {\<aa>} \<in>\<^sub>\<circ> cat_Set \<alpha>\<lparr>Obj\<rparr>"
    by (simp add: Limit_vsingleton_in_VsetI cat_Set_components(1))
  from
    ntcf_cf_comp_is_iso_ntcf[
      OF \<KK>.ntcf_pointed_inv_is_iso_ntcf[OF assms(3)] assms(1)
      ]
  have \<aa>\<KK>: "ntcf_pointed_inv \<alpha> \<aa> \<circ>\<^sub>N\<^sub>T\<^sub>C\<^sub>F\<^sub>-\<^sub>C\<^sub>F \<KK> :
    \<KK> \<mapsto>\<^sub>C\<^sub>F\<^sub>.\<^sub>i\<^sub>s\<^sub>o Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>cat_Set \<alpha> (set {\<aa>},-) \<circ>\<^sub>C\<^sub>F \<KK> : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
    by (cs_prems cs_simp: cat_cs_simps)
  from iso_ntcf_is_iso_arr(1)[OF \<aa>\<KK>] r\<psi> assms(3) have [cat_cs_simps]:
    "((ntcf_pointed_inv \<alpha> \<aa> \<circ>\<^sub>N\<^sub>T\<^sub>C\<^sub>F\<^sub>-\<^sub>C\<^sub>F \<KK> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F \<psi>)\<lparr>NTMap\<rparr>\<lparr>r\<rparr>\<lparr>ArrVal\<rparr>\<lparr>\<CC>\<lparr>CId\<rparr>\<lparr>r\<rparr>\<rparr>) =
      ntcf_paa \<aa> (\<KK>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>) (\<psi>\<lparr>NTMap\<rparr>\<lparr>r\<rparr>\<lparr>ArrVal\<rparr>\<lparr>\<CC>\<lparr>CId\<rparr>\<lparr>r\<rparr>\<rparr>)"
    by
      (
        cs_concl
          cs_simp: cat_cs_simps
          cs_intro: cat_Set_cs_intros cat_cs_intros cat_op_intros
      )
  show "universal_arrow_of
    \<KK> (set {\<aa>}) r (ntcf_paa \<aa> (\<KK>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>) (\<psi>\<lparr>NTMap\<rparr>\<lparr>r\<rparr>\<lparr>ArrVal\<rparr>\<lparr>\<CC>\<lparr>CId\<rparr>\<lparr>r\<rparr>\<rparr>))"
    by
      (
        rule \<KK>.cf_universal_arrow_of_if_is_iso_ntcf
          [
            OF r\<psi>(1) set_\<aa> ntcf_vcomp_is_iso_ntcf[OF \<aa>\<KK> r\<psi>(2)],
            unfolded cat_cs_simps
          ]
      )
qed

lemma universal_arrow_of_if_cat_corepresentation:
  \<comment>\<open>See Proposition 2 in Chapter III-2 in \cite{mac_lane_categories_2010}.\<close>
  assumes "category \<alpha> \<CC>"
    and "\<KK> : op_cat \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
    and "cat_corepresentation \<alpha> \<KK> r \<psi>"
    and "\<aa> \<in>\<^sub>\<circ> cat_Set \<alpha>\<lparr>Obj\<rparr>"
  shows "universal_arrow_of
    \<KK> (set {\<aa>}) r (ntcf_paa \<aa> (\<KK>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>) (\<psi>\<lparr>NTMap\<rparr>\<lparr>r\<rparr>\<lparr>ArrVal\<rparr>\<lparr>\<CC>\<lparr>CId\<rparr>\<lparr>r\<rparr>\<rparr>))"
proof-
  interpret \<CC>: category \<alpha> \<CC> by (rule assms(1))
  note r\<psi> = cat_corepresentationD[OF assms(3,1,2)]
  note [cat_op_simps] = \<CC>.cat_op_cat_cf_Hom_snd[OF r\<psi>(1)]
  have rep: "cat_representation \<alpha> \<KK> r \<psi>"
    by (intro cat_representationI, rule assms(2), unfold cat_op_simps; rule r\<psi>)
  show ?thesis
    by
      (
        rule universal_arrow_of_if_cat_representation[
          OF assms(2) rep assms(4), unfolded cat_op_simps
          ]
      )
qed

lemma cat_representation_if_universal_arrow_of:
  \<comment>\<open>See Proposition 2 in Chapter III-2 in \cite{mac_lane_categories_2010}.\<close>
  assumes "\<KK> : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
    and "\<aa> \<in>\<^sub>\<circ> cat_Set \<alpha>\<lparr>Obj\<rparr>"
    and "universal_arrow_of \<KK> (set {\<aa>}) r u"
  shows "cat_representation \<alpha> \<KK> r (Yoneda_arrow \<alpha> \<KK> r (u\<lparr>ArrVal\<rparr>\<lparr>\<aa>\<rparr>))"
proof-

  let ?Y = \<open>Yoneda_component \<KK> r (u\<lparr>ArrVal\<rparr>\<lparr>\<aa>\<rparr>)\<close>

  interpret \<KK>: is_functor \<alpha> \<CC> \<open>cat_Set \<alpha>\<close> \<KK> by (rule assms(1))

  note ua = \<KK>.universal_arrow_ofD[OF assms(3)]

  from ua(2) have u\<aa>: "u\<lparr>ArrVal\<rparr>\<lparr>\<aa>\<rparr> \<in>\<^sub>\<circ> \<KK>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>"
    by
      (
        cs_concl cs_shallow
          cs_intro: V_cs_intros cat_Set_cs_intros cat_cs_intros
      )

  have [cat_cs_simps]: "Yoneda_arrow \<alpha> \<KK> r (u\<lparr>ArrVal\<rparr>\<lparr>\<aa>\<rparr>)\<lparr>NTMap\<rparr>\<lparr>c\<rparr> = ?Y c"
    if "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" for c
    using that
    by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  from ua(1) have [cat_cs_simps]: "Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<CC>(r,-)\<lparr>ObjMap\<rparr>\<lparr>c\<rparr> = Hom \<CC> r c"
    if "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" for c
    using that
    by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_op_intros)

  show ?thesis
  proof
    (
      intro cat_representationI is_iso_ntcfI,
      rule assms(1),
      rule ua(1),
      rule \<KK>.HomDom.cat_Yoneda_arrow_is_ntcf[OF assms(1) ua(1) u\<aa>],
      rule cat_Set_is_iso_arrI,
      simp_all only: cat_cs_simps
    )

    fix c assume prems: "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    with ua(1,2) show Yc: "?Y c : Hom \<CC> r c \<mapsto>\<^bsub>cat_Set \<alpha>\<^esub> \<KK>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>"
      by
        (
          cs_concl cs_shallow
            cs_intro: V_cs_intros cat_Set_cs_intros cat_cs_intros
        )

    note YcD = cat_Set_is_arrD[OF Yc]

    interpret Yc: arr_Set \<alpha> \<open>?Y c\<close> by (rule YcD(1))

    show dom_Yc: "\<D>\<^sub>\<circ> (?Y c\<lparr>ArrVal\<rparr>) = Hom \<CC> r c"
      by (simp add: \<KK>.Yoneda_component_ArrVal_vdomain)

    show "v11 (?Y c\<lparr>ArrVal\<rparr>)"
    proof(intro Yc.ArrVal.vsv_valeq_v11I, unfold dom_Yc in_Hom_iff)

      fix g f assume prems':
        "g : r \<mapsto>\<^bsub>\<CC>\<^esub> c" "f : r \<mapsto>\<^bsub>\<CC>\<^esub> c" "?Y c\<lparr>ArrVal\<rparr>\<lparr>g\<rparr> = ?Y c\<lparr>ArrVal\<rparr>\<lparr>f\<rparr>"

      from prems have c: "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" by auto

      from prems'(3,1,2) have \<KK>gu\<aa>_\<KK>fu\<aa>:
        "\<KK>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr>\<lparr>ArrVal\<rparr>\<lparr>u\<lparr>ArrVal\<rparr>\<lparr>\<aa>\<rparr>\<rparr> = \<KK>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>\<lparr>ArrVal\<rparr>\<lparr>u\<lparr>ArrVal\<rparr>\<lparr>\<aa>\<rparr>\<rparr>"
        by (cs_prems cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

      from prems'(1,2) ua(1,2) have \<KK>g_u:
        "\<KK>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> u : set {\<aa>} \<mapsto>\<^bsub>cat_Set \<alpha>\<^esub> \<KK>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>"
        and \<KK>f_u:
        "\<KK>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> u : set {\<aa>} \<mapsto>\<^bsub>cat_Set \<alpha>\<^esub> \<KK>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>"
        by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)+
      then have dom_lhs: "\<D>\<^sub>\<circ> ((\<KK>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> u)\<lparr>ArrVal\<rparr>) = set {\<aa>}"
        and dom_rhs: "\<D>\<^sub>\<circ> ((\<KK>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> u)\<lparr>ArrVal\<rparr>) = set {\<aa>}"
        by (cs_concl cs_shallow cs_simp: cat_cs_simps)+

      have \<KK>g_\<KK>f: "\<KK>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> u = \<KK>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> u"
      proof(rule arr_Set_eqI)
        from \<KK>g_u show arr_Set_\<KK>g_u: "arr_Set \<alpha> (\<KK>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> u)"
          by (auto dest: cat_Set_is_arrD)
        from \<KK>f_u show arr_Set_\<KK>f_u: "arr_Set \<alpha> (\<KK>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> u)"
          by (auto dest: cat_Set_is_arrD)
        show
          "(\<KK>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> u)\<lparr>ArrVal\<rparr> =
            (\<KK>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> u)\<lparr>ArrVal\<rparr>"
        proof(rule vsv_eqI, unfold dom_lhs dom_rhs vsingleton_iff; (simp only:)?)
          from prems'(1,2) ua(2) show
            "(\<KK>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> u)\<lparr>ArrVal\<rparr>\<lparr>\<aa>\<rparr> =
              (\<KK>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> u)\<lparr>ArrVal\<rparr>\<lparr>\<aa>\<rparr>"
            by
              (
                cs_concl cs_shallow
                  cs_simp: cat_cs_simps \<KK>gu\<aa>_\<KK>fu\<aa>
                  cs_intro: V_cs_intros cat_cs_intros
              )
        qed (use arr_Set_\<KK>g_u arr_Set_\<KK>f_u in auto)
      qed (use \<KK>g_u \<KK>f_u in \<open>cs_concl cs_shallow cs_simp: cat_cs_simps\<close>)+
      from prems'(1) ua(2) have
        "\<KK>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> u : set {\<aa>} \<mapsto>\<^bsub>cat_Set \<alpha>\<^esub> \<KK>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>"
        by (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      from ua(3)[OF c this] obtain h where h: "h : r \<mapsto>\<^bsub>\<CC>\<^esub> c"
        and \<KK>g_u_def:
          "\<KK>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> u = umap_of \<KK> (set {\<aa>}) r u c\<lparr>ArrVal\<rparr>\<lparr>h\<rparr>"
        and h_unique: "\<And>h'.
          \<lbrakk>
            h' : r \<mapsto>\<^bsub>\<CC>\<^esub> c;
            \<KK>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> u = umap_of \<KK> (set {\<aa>}) r u c\<lparr>ArrVal\<rparr>\<lparr>h'\<rparr>
          \<rbrakk> \<Longrightarrow> h' = h"
        by metis
      from prems'(1,2) ua(2) have
        "\<KK>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> u = umap_of \<KK> (set {\<aa>}) r u c\<lparr>ArrVal\<rparr>\<lparr>g\<rparr>"
        "\<KK>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> u = umap_of \<KK> (set {\<aa>}) r u c\<lparr>ArrVal\<rparr>\<lparr>f\<rparr>"
        by
          (
            cs_concl cs_shallow
              cs_simp: cat_cs_simps \<KK>g_\<KK>f cs_intro: cat_cs_intros
          )+
      from h_unique[OF prems'(1) this(1)] h_unique[OF prems'(2) this(2)] show
        "g = f"
        by simp
    qed

    show "\<R>\<^sub>\<circ> (?Y c\<lparr>ArrVal\<rparr>) = \<KK>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>"
    proof
      (
        intro
          vsubset_antisym Yc.arr_Par_ArrVal_vrange[unfolded YcD]
          vsubsetI
      )
      fix y assume prems': "y \<in>\<^sub>\<circ> \<KK>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>"
      from prems have \<KK>c: "\<KK>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr> \<in>\<^sub>\<circ> cat_Set \<alpha>\<lparr>Obj\<rparr>"
        by (cs_concl cs_shallow cs_intro: cat_cs_intros)
      from ua(3)[OF prems \<KK>.ntcf_paa_is_arr[OF assms(2) \<KK>c prems']] obtain f
        where f: "f : r \<mapsto>\<^bsub>\<CC>\<^esub> c"
          and ntcf_paa_y:
            "ntcf_paa \<aa> (\<KK>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>) y = umap_of \<KK> (set {\<aa>}) r u c\<lparr>ArrVal\<rparr>\<lparr>f\<rparr>"
          and f_unique: "\<And>f'.
            \<lbrakk>
              f' : r \<mapsto>\<^bsub>\<CC>\<^esub> c;
              ntcf_paa \<aa> (\<KK>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>) y = umap_of \<KK> (set {\<aa>}) r u c\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>
            \<rbrakk> \<Longrightarrow> f' = f"
        by metis
      from ntcf_paa_y f ua(2) have
        "ntcf_paa \<aa> (\<KK>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>) y = \<KK>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> u"
        by (cs_prems cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      then have
        "ntcf_paa \<aa> (\<KK>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>) y\<lparr>ArrVal\<rparr>\<lparr>\<aa>\<rparr> =
          (\<KK>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>cat_Set \<alpha>\<^esub> u)\<lparr>ArrVal\<rparr>\<lparr>\<aa>\<rparr>"
        by simp
      from this f ua(2) have [symmetric, cat_cs_simps]:
        "y = \<KK>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>\<lparr>ArrVal\<rparr>\<lparr>u\<lparr>ArrVal\<rparr>\<lparr>\<aa>\<rparr>\<rparr>"
        by
          (
            cs_prems cs_shallow
              cs_simp: cat_cs_simps cs_intro: V_cs_intros cat_cs_intros
          )
      show "y \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (?Y c\<lparr>ArrVal\<rparr>)"
        by (intro Yc.ArrVal.vsv_vimageI2')
          (
            use f in
              \<open>
                cs_concl cs_shallow
                  cs_simp: cat_cs_simps cs_intro: cat_cs_intros
              \<close>
          )+
    qed
  qed

qed

lemma cat_corepresentation_if_universal_arrow_of:
  \<comment>\<open>See Proposition 2 in Chapter III-2 in \cite{mac_lane_categories_2010}.\<close>
  assumes "category \<alpha> \<CC>"
    and "\<KK> : op_cat \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Set \<alpha>"
    and "\<aa> \<in>\<^sub>\<circ> cat_Set \<alpha>\<lparr>Obj\<rparr>"
    and "universal_arrow_of \<KK> (set {\<aa>}) r u"
  shows "cat_corepresentation \<alpha> \<KK> r (Yoneda_arrow \<alpha> \<KK> r (u\<lparr>ArrVal\<rparr>\<lparr>\<aa>\<rparr>))"
proof-
  interpret \<CC>: category \<alpha> \<CC> by (rule assms(1))
  interpret \<KK>: is_functor \<alpha> \<open>op_cat \<CC>\<close> \<open>cat_Set \<alpha>\<close> \<KK> by (rule assms(2))
  note ua = \<KK>.universal_arrow_ofD[OF assms(4), unfolded cat_op_simps]
  note [cat_op_simps] = \<CC>.cat_op_cat_cf_Hom_snd[OF ua(1)]
  show ?thesis
    by
      (
        intro cat_corepresentationI,
        rule assms(1),
        rule assms(2),
        rule ua(1),
        rule cat_representationD(2)
          [
            OF
              cat_representation_if_universal_arrow_of[OF assms(2,3,4)]
              assms(2),
            unfolded cat_op_simps
          ]
      )
qed

subsection\<open>Limits and colimits as universal cones\<close>

lemma is_tm_cat_limit_if_cat_corepresentation:
  \<comment>\<open>See Definition 3.1.5 in Section 3.1 in \cite{riehl_category_2016}.\<close>
  assumes "\<FF> : \<JJ> \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<CC>"
    and "cat_corepresentation \<alpha> (tm_cf_Cone \<alpha> \<FF>) r \<psi>"
    (is \<open>cat_corepresentation \<alpha> ?Cone r \<psi>\<close>)
  shows "ntcf_of_ntcf_arrow \<JJ> \<CC> (\<psi>\<lparr>NTMap\<rparr>\<lparr>r\<rparr>\<lparr>ArrVal\<rparr>\<lparr>\<CC>\<lparr>CId\<rparr>\<lparr>r\<rparr>\<rparr>) :
    r <\<^sub>C\<^sub>F\<^sub>.\<^sub>t\<^sub>m\<^sub>.\<^sub>l\<^sub>i\<^sub>m \<FF> : \<JJ> \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<CC>"
    (is \<open>ntcf_of_ntcf_arrow \<JJ> \<CC> ?\<psi>r1r : r <\<^sub>C\<^sub>F\<^sub>.\<^sub>t\<^sub>m\<^sub>.\<^sub>l\<^sub>i\<^sub>m \<FF> : \<JJ> \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<CC>\<close>)
proof-

  let ?P = \<open>ntcf_paa 0\<close> and ?Funct = \<open>cat_Funct \<alpha> \<JJ> \<CC>\<close>

  interpret \<FF>: is_tm_functor \<alpha> \<JJ> \<CC> \<FF> by (rule assms(1))
  interpret Funct: category \<alpha> ?Funct
    by
      (
        cs_concl cs_shallow cs_intro:
          cat_small_cs_intros cat_cs_intros cat_FUNCT_cs_intros
      )
  note r\<psi> = cat_corepresentationD[
      OF assms(2) \<FF>.HomCod.category_axioms \<FF>.tm_cf_cf_Cone_is_functor
      ]
  interpret \<psi>: is_iso_ntcf \<alpha> \<open>op_cat \<CC>\<close> \<open>cat_Set \<alpha>\<close> \<open>Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<alpha>\<^esub>\<CC>(-,r)\<close> ?Cone \<psi>
    by (rule r\<psi>(2))
  have 0: "0 \<in>\<^sub>\<circ> cat_Set \<alpha>\<lparr>Obj\<rparr>" unfolding cat_Set_components by auto
  note ua = universal_arrow_of_if_cat_corepresentation[
      OF \<FF>.HomCod.category_axioms \<FF>.tm_cf_cf_Cone_is_functor assms(2) 0
      ]

  show ?thesis
  proof(rule is_tm_cat_limitI')

    from r\<psi>(1) have [cat_FUNCT_cs_simps]:
      "cf_of_cf_map \<JJ> \<CC> (cf_map (cf_const \<JJ> \<CC> r)) = cf_const \<JJ> \<CC> r"
      by
        (
          cs_concl
            cs_simp: cat_FUNCT_cs_simps
            cs_intro: cat_cs_intros cat_FUNCT_cs_intros
        )
    from \<psi>.ntcf_NTMap_is_arr[unfolded cat_op_simps, OF r\<psi>(1)] r\<psi>(1) have
      "\<psi>\<lparr>NTMap\<rparr>\<lparr>r\<rparr> :
        Hom \<CC> r r \<mapsto>\<^bsub>cat_Set \<alpha>\<^esub> Hom ?Funct (cf_map (cf_const \<JJ> \<CC> r)) (cf_map \<FF>)"
      by
        (
          cs_prems
            cs_simp: cat_small_cs_simps cat_cs_simps cat_op_simps
            cs_intro: cat_cs_intros
        )
    with r\<psi>(1) have \<psi>r_r:
      "?\<psi>r1r : cf_map (cf_const \<JJ> \<CC> r) \<mapsto>\<^bsub>?Funct\<^esub> cf_map \<FF>"
      by
        (
          cs_concl cs_shallow cs_intro:
            cat_Set_cs_intros cat_cs_intros in_Hom_iff[symmetric]
        )

    from r\<psi>(1) cat_Funct_is_arrD(1)[OF \<psi>r_r, unfolded cat_FUNCT_cs_simps]
    show "ntcf_of_ntcf_arrow \<JJ> \<CC> ?\<psi>r1r : r <\<^sub>C\<^sub>F\<^sub>.\<^sub>t\<^sub>m\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e \<FF> : \<JJ> \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<CC>"
      by (intro is_tm_cat_coneI)
        (cs_concl cs_shallow cs_intro: cat_cs_intros cat_small_cs_intros)

    fix r' u' assume "u' : r' <\<^sub>C\<^sub>F\<^sub>.\<^sub>t\<^sub>m\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e \<FF> : \<JJ> \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<CC>"
    then interpret u': is_tm_cat_cone \<alpha> r' \<JJ> \<CC> \<FF> u' .

    have Cone_r': "tm_cf_Cone \<alpha> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r'\<rparr> \<in>\<^sub>\<circ> cat_Set \<alpha>\<lparr>Obj\<rparr>"
      by (cs_concl cs_intro: cat_lim_cs_intros cat_cs_intros cat_op_intros)
    from r\<psi>(1) have Cone_r: "tm_cf_Cone \<alpha> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr> \<in>\<^sub>\<circ> cat_Set \<alpha>\<lparr>Obj\<rparr>"
      by (cs_concl cs_shallow cs_intro: cat_cs_intros cat_op_intros)
    from r\<psi>(1) have \<psi>r1r:
      "\<psi>\<lparr>NTMap\<rparr>\<lparr>r\<rparr>\<lparr>ArrVal\<rparr>\<lparr>\<CC>\<lparr>CId\<rparr>\<lparr>r\<rparr>\<rparr> \<in>\<^sub>\<circ> tm_cf_Cone \<alpha> \<FF>\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>"
      by
        (
          cs_concl cs_shallow
            cs_simp: cat_small_cs_simps cat_cs_simps cat_op_simps
            cs_intro: cat_cs_intros
        )
    have u': "ntcf_arrow u' \<in>\<^sub>\<circ> ?Cone\<lparr>ObjMap\<rparr>\<lparr>r'\<rparr>"
      by
        (
          cs_concl
            cs_simp: cat_small_cs_simps
            cs_intro: cat_small_cs_intros cat_FUNCT_cs_intros cat_cs_intros
        )

    have [cat_cs_simps]:
      "cf_of_cf_map \<JJ> \<CC> (cf_map \<FF>) = \<FF>"
      "cf_of_cf_map \<JJ> \<CC> (cf_map (cf_const \<JJ> \<CC> r)) = cf_const \<JJ> \<CC> r"
      by (cs_concl cs_simp: cat_FUNCT_cs_simps)+

    from Cone_r 0 \<psi>r1r r\<psi>(1) have \<psi>r1r_is_arr: "\<psi>\<lparr>NTMap\<rparr>\<lparr>r\<rparr>\<lparr>ArrVal\<rparr>\<lparr>\<CC>\<lparr>CId\<rparr>\<lparr>r\<rparr>\<rparr> :
      cf_map (cf_const \<JJ> \<CC> r) \<mapsto>\<^bsub>?Funct\<^esub> cf_map \<FF>"
      by
        (
          cs_concl cs_shallow
            cs_simp: cat_cs_simps cat_small_cs_simps
            cs_intro: cat_cs_intros cat_op_intros
        )

    from r\<psi>(1) have [cat_cs_intros]:
      "Hom ?Funct (cf_map (cf_const \<JJ> \<CC> r)) (cf_map \<FF>) \<in>\<^sub>\<circ> cat_Set \<alpha>\<lparr>Obj\<rparr>"
      unfolding cat_Set_components(1)
      by (intro Funct.cat_Hom_in_Vset)
        (
          cs_concl
            cs_simp: cat_FUNCT_cs_simps
            cs_intro: cat_small_cs_intros cat_FUNCT_cs_intros cat_cs_intros
        )+

    note \<psi>r1r_is_arrD = cat_Funct_is_arrD[OF \<psi>r1r_is_arr, unfolded cat_cs_simps]

    from is_functor.universal_arrow_ofD(3)
      [
        OF \<FF>.tm_cf_cf_Cone_is_functor ua,
        unfolded cat_op_simps,
        OF u'.cat_cone_obj \<FF>.ntcf_paa_is_arr[OF 0 Cone_r' u']
      ]
    obtain f where f: "f : r' \<mapsto>\<^bsub>\<CC>\<^esub> r"
      and Pf: "?P (?Cone\<lparr>ObjMap\<rparr>\<lparr>r'\<rparr>) (ntcf_arrow u') =
        umap_of ?Cone (set {0}) r (?P (?Cone\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>) ?\<psi>r1r) r'\<lparr>ArrVal\<rparr>\<lparr>f\<rparr>"
      and f_unique: "\<And>f'.
        \<lbrakk>
          f' : r' \<mapsto>\<^bsub>\<CC>\<^esub> r;
          ?P (?Cone\<lparr>ObjMap\<rparr>\<lparr>r'\<rparr>) (ntcf_arrow u') =
            umap_of ?Cone (set {0}) r (?P (?Cone\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>) ?\<psi>r1r) r'\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>
        \<rbrakk> \<Longrightarrow> f' = f"
      by metis

    show "\<exists>!f.
      f : r' \<mapsto>\<^bsub>\<CC>\<^esub> r \<and>
      u' = ntcf_of_ntcf_arrow \<JJ> \<CC> ?\<psi>r1r \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<JJ> \<CC> f"
    proof(intro ex1I conjI; (elim conjE)?)
      show "f : r' \<mapsto>\<^bsub>\<CC>\<^esub> r" by (rule f)
      from Pf Cone_r 0 f \<psi>r1r \<psi>r1r_is_arr \<psi>r1r_is_arrD(1) show
        "u' = ntcf_of_ntcf_arrow \<JJ> \<CC> ?\<psi>r1r \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<JJ> \<CC> f"
        by (subst (asm) \<psi>r1r_is_arrD(2))
          (
            cs_prems
              cs_simp: cat_FUNCT_cs_simps cat_small_cs_simps cat_cs_simps
              cs_intro:
                cat_small_cs_intros
                cat_cs_intros
                cat_FUNCT_cs_intros
                cat_prod_cs_intros
                cat_op_intros
          )

      fix f' assume prems:
        "f' : r' \<mapsto>\<^bsub>\<CC>\<^esub> r"
        "u' = ntcf_of_ntcf_arrow \<JJ> \<CC> ?\<psi>r1r \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<JJ> \<CC> f'"
      from Pf Cone_r 0 f \<psi>r1r \<psi>r1r_is_arr \<psi>r1r_is_arrD(1) prems(1) have
        "?P (?Cone\<lparr>ObjMap\<rparr>\<lparr>r'\<rparr>) (ntcf_arrow u') =
          umap_of ?Cone (set {0}) r (?P (?Cone\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>) ?\<psi>r1r) r'\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>"
        by (subst \<psi>r1r_is_arrD(2))
          (
            cs_concl
              cs_simp: cat_FUNCT_cs_simps cat_small_cs_simps cat_cs_simps prems(2)
              cs_intro:
                cat_small_cs_intros
                cat_FUNCT_cs_intros
                cat_cs_intros
                cat_prod_cs_intros
                cat_op_intros
          )
      from f_unique[OF prems(1) this] show "f' = f" .
    qed

  qed

qed

lemma cat_corepresentation_if_is_tm_cat_limit:
  \<comment>\<open>See Definition 3.1.5 in Section 3.1 in \cite{riehl_category_2016}.\<close>
  assumes "\<psi> : r <\<^sub>C\<^sub>F\<^sub>.\<^sub>t\<^sub>m\<^sub>.\<^sub>l\<^sub>i\<^sub>m \<FF> : \<JJ> \<mapsto>\<mapsto>\<^sub>C\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "cat_corepresentation
    \<alpha> (tm_cf_Cone \<alpha> \<FF>) r (Yoneda_arrow \<alpha> (tm_cf_Cone \<alpha> \<FF>) r (ntcf_arrow \<psi>))"
    (is \<open>cat_corepresentation \<alpha> ?Cone r ?Y\<psi>\<close>)
proof-

  let ?Funct = \<open>cat_Funct \<alpha> \<JJ> \<CC>\<close>
    and ?P_\<psi> = \<open>ntcf_paa 0 (?Cone\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>) (ntcf_arrow \<psi>)\<close>
    and ?ntcf_of = \<open>ntcf_of_ntcf_arrow \<JJ> \<CC>\<close>

  interpret \<psi>: is_tm_cat_limit \<alpha> \<JJ> \<CC> \<FF> r \<psi> by (rule assms(1))
  interpret Funct: category \<alpha> ?Funct
    by
      (
        cs_concl cs_shallow cs_intro:
          cat_small_cs_intros cat_cs_intros cat_FUNCT_cs_intros
      )
  interpret Cone: is_functor \<alpha> \<open>op_cat \<CC>\<close> \<open>cat_Set \<alpha>\<close> \<open>?Cone\<close>
    by (rule \<psi>.NTCod.tm_cf_cf_Cone_is_functor)

  have 0: "0 \<in>\<^sub>\<circ> cat_Set \<alpha>\<lparr>Obj\<rparr>" unfolding cat_Set_components by auto
  have ntcf_arrow_\<psi>:
    "ntcf_arrow \<psi> : cf_map (cf_const \<JJ> \<CC> r) \<mapsto>\<^bsub>?Funct\<^esub> cf_map \<FF>"
    by (cs_concl cs_shallow cs_intro: cat_small_cs_intros cat_FUNCT_cs_intros)
  from \<psi>.cat_cone_obj 0 ntcf_arrow_\<psi> have P_\<psi>:
    "?P_\<psi> : set {0} \<mapsto>\<^bsub>cat_Set \<alpha>\<^esub> ?Cone\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>"
    by
      (
        cs_concl cs_shallow
          cs_intro: cat_cs_intros cat_op_intros
          cs_simp: cat_small_cs_simps cat_FUNCT_cs_simps
      )

  have "universal_arrow_of ?Cone (set {0}) r ?P_\<psi>"
  proof(rule Cone.universal_arrow_ofI, unfold cat_op_simps, rule \<psi>.cat_cone_obj)

    from 0 \<psi>.cat_cone_obj show "?P_\<psi> : set {0} \<mapsto>\<^bsub>cat_Set \<alpha>\<^esub> ?Cone\<lparr>ObjMap\<rparr>\<lparr>r\<rparr>"
      by
        (
          cs_concl
            cs_intro:
              cat_small_cs_intros
              cat_cs_intros
              cat_FUNCT_cs_intros
              cat_op_intros
            cs_simp: cat_small_cs_simps
        )

    fix r' u' assume prems:
      "r' \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" "u' : set {0} \<mapsto>\<^bsub>cat_Set \<alpha>\<^esub> ?Cone\<lparr>ObjMap\<rparr>\<lparr>r'\<rparr>"

    let ?const_r' = \<open>cf_map (cf_const \<JJ> \<CC> r')\<close>
    let ?Hom_r\<FF> = \<open>Hom ?Funct ?const_r' (cf_map \<FF>)\<close>

    from prems(2,1) have u': "u' : set {0} \<mapsto>\<^bsub>cat_Set \<alpha>\<^esub> ?Hom_r\<FF>"
      by
        (
          cs_prems cs_shallow
            cs_simp: cat_small_cs_simps cat_cs_simps cs_intro: cat_cs_intros
        )
    from prems(1) have [cat_FUNCT_cs_simps]:
      "cf_of_cf_map \<JJ> \<CC> ?const_r' = cf_const \<JJ> \<CC> r'"
      by
        (
          cs_concl
            cs_simp: cat_cs_simps cat_FUNCT_cs_simps cs_intro: cat_cs_intros
        )

    from
      cat_Set_ArrVal_app_vrange[OF prems(2) vintersection_vsingleton]
      prems(1)
    have "u'\<lparr>ArrVal\<rparr>\<lparr>0\<rparr> : ?const_r' \<mapsto>\<^bsub>?Funct\<^esub> cf_map \<FF>"
      by (cs_prems cs_shallow cs_simp: cat_small_cs_simps cat_cs_simps)
    note u'0 = cat_Funct_is_arrD[OF this, unfolded cat_FUNCT_cs_simps]

    interpret u'0: is_tm_cat_cone \<alpha> r' \<JJ> \<CC> \<FF> \<open>?ntcf_of (u'\<lparr>ArrVal\<rparr>\<lparr>0\<rparr>)\<close>
      by
        (
          rule is_tm_cat_coneI[
            OF is_tm_ntcfD(1)[OF u'0(1)] \<psi>.NTCod.is_tm_functor_axioms prems(1)
            ]
        )

    from \<psi>.tm_cat_lim_ua_fo[OF u'0.is_cat_cone_axioms] obtain f
      where f: "f : r' \<mapsto>\<^bsub>\<CC>\<^esub> r"
        and u'0_def: "?ntcf_of (u'\<lparr>ArrVal\<rparr>\<lparr>0\<rparr>) = \<psi> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<JJ> \<CC> f"
        and f_unique: "\<And>f'.
          \<lbrakk>
            f' : r' \<mapsto>\<^bsub>\<CC>\<^esub> r;
            ?ntcf_of (u'\<lparr>ArrVal\<rparr>\<lparr>0\<rparr>) = \<psi> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<JJ> \<CC> f'
          \<rbrakk> \<Longrightarrow> f' = f"
      by metis

    note [cat_FUNCT_cs_simps] =
      \<psi>.ntcf_paa_ArrVal u'0(2)[symmetric] u'0_def[symmetric]

    show "\<exists>!f'.
      f' : r' \<mapsto>\<^bsub>\<CC>\<^esub> r \<and> u' = umap_of ?Cone (set {0}) r ?P_\<psi> r'\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>"
    proof(intro ex1I conjI; (elim conjE)?; (rule f)?)

      from f 0 u' ntcf_arrow_\<psi> show
        "u' = umap_of ?Cone (set {0}) r ?P_\<psi> r'\<lparr>ArrVal\<rparr>\<lparr>f\<rparr>"
        by (*slow*)
          (
            cs_concl
              cs_simp: cat_cs_simps
              cs_intro:
                cat_small_cs_intros
                cat_FUNCT_cs_intros
                cat_prod_cs_intros
                cat_cs_intros
                cat_op_intros
              cs_simp: cat_FUNCT_cs_simps cat_small_cs_simps
          )

      fix f' assume prems':
        "f' : r' \<mapsto>\<^bsub>\<CC>\<^esub> r"
        "u' = umap_of ?Cone (set {0}) r ?P_\<psi> r'\<lparr>ArrVal\<rparr>\<lparr>f'\<rparr>"

      let ?f' = \<open>ntcf_const \<JJ> \<CC> f'\<close>

      from prems'(2,1) 0 ntcf_arrow_\<psi> P_\<psi> have
        "u' = ntcf_paa 0 ?Hom_r\<FF> (ntcf_arrow (\<psi> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ?f'))"
        unfolding
          Cone.umap_of_ArrVal_app[unfolded cat_op_simps, OF prems'(1) P_\<psi>]
        by (*very slow*)
          (
            cs_prems
              cs_simp: cat_FUNCT_cs_simps cat_small_cs_simps cat_cs_simps
              cs_intro:
                cat_small_cs_intros
                cat_FUNCT_cs_intros
                cat_prod_cs_intros
                cat_cs_intros
                cat_op_intros
          )
      then have
        "?ntcf_of (u'\<lparr>ArrVal\<rparr>\<lparr>0\<rparr>) =
          ?ntcf_of ((ntcf_paa 0 ?Hom_r\<FF> (ntcf_arrow (\<psi> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ?f')))\<lparr>ArrVal\<rparr>\<lparr>0\<rparr>)"
        by simp
      from this prems'(1) have "?ntcf_of (u'\<lparr>ArrVal\<rparr>\<lparr>0\<rparr>) = \<psi> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ?f'"
        by
          (
            cs_prems cs_shallow
              cs_simp: cat_cs_simps cat_FUNCT_cs_simps cs_intro: cat_cs_intros
          )
      from f_unique[OF prems'(1) this] show "f' = f" .

    qed

  qed

  from
    cat_corepresentation_if_universal_arrow_of[
      OF \<psi>.NTDom.HomCod.category_axioms Cone.is_functor_axioms 0 this
      ]
  show "cat_corepresentation \<alpha> ?Cone r ?Y\<psi>"
    by (cs_prems cs_shallow cs_simp: cat_cs_simps)

qed

text\<open>\newpage\<close>

end


(*  Title:      HOL/Auth/n_mesi_lemma_inv__2_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_mesi Protocol Case Study*}

theory n_mesi_lemma_inv__2_on_rules imports n_mesi_lemma_on_inv__2
begin
section{*All lemmas on causal relation between inv__2*}
lemma lemma_inv__2_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__2  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i. i\<le>N\<and>r=n_t1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_t2 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_t3 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_t4 N i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_t1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_t1Vsinv__2) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_t2 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_t2Vsinv__2) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_t3 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_t3Vsinv__2) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_t4 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_t4Vsinv__2) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


theory Friend_Traceback
imports Traceback_Intro
begin

subsection \<open>Tracing Back Friendship Status\<close>

text \<open>We prove the following traceback property:
If, at some point \<open>t\<close> on a system trace, the users \<open>UID\<close> and \<open>UID'\<close> are friends,
then one of the following holds:
\begin{itemize}
\item Either \<open>UID\<close> had issued a friend request to \<open>UID'\<close>, eventually followed by an approval
(i.e., a successful \<open>UID\<close>-friend creation action) by \<open>UID'\<close> such that between
that approval and \<open>t\<close> there was no successful \<open>UID'\<close>-unfriending (i.e., friend deletion)
by \<open>UID\<close> or \<open>UID\<close>-unfriending by \<open>UID'\<close>
\item Or vice versa (with \<open>UID\<close> and \<open>UID'\<close> swapped)
\end{itemize}

This property is captured by the predicate \<open>proper\<close>, which decomposes any valid system trace tr
starting in the initial state
for which the target state \<open>tgtOf (last tr)\<close> has \<open>UID\<close> and \<open>UID'\<close> as friends,
as follows: tr is the concatenation of \<open>tr1\<close>, \<open>trn\<close>, \<open>tr2\<close>, \<open>trnn\<close> and \<open>tr3\<close> where
\begin{itemize}
\item \<open>trn\<close> represents the time of the relevant friend request
\item \<open>trnn\<close> represents the time of the approval of this request
\item \<open>tr3\<close> contains no unfriending between the two users
\end{itemize}

The main theorem states that \<open>proper tr\<close>
holds for any trace \<open>tr\<close> that leads to \<open>UID\<close> and \<open>UID'\<close> being friends.
\<close>

consts UID :: userID
consts UID' :: userID

text \<open>\<open>SFRC\<close> means ``is a successful friend request creation''\<close>

fun SFRC :: "userID \<Rightarrow> userID \<Rightarrow> (state,act,out) trans \<Rightarrow> bool" where
"SFRC uidd uidd' (Trans s (Cact (cFriendReq uid p uid' _)) ou s') = (ou = outOK \<and> (uid,uid') = (uidd,uidd'))"
|
"SFRC uidd uidd' _ = False"

text \<open>\<open>SFC\<close> means ``is a successful friend creation'' \<close>

fun SFC :: "userID \<Rightarrow> userID \<Rightarrow> (state,act,out) trans \<Rightarrow> bool" where
"SFC uidd uidd' (Trans s (Cact (cFriend uid p uid')) ou s') = (ou = outOK \<and> (uid,uid') = (uidd,uidd'))"
|
"SFC uidd uidd' _ = False"

text \<open>\<open>SFD\<close> means ``is a successful friend deletion'' \<close>

fun SFD :: "userID \<Rightarrow> userID \<Rightarrow> (state,act,out) trans \<Rightarrow> bool" where
"SFD uidd uidd' (Trans s (Dact (dFriend uid p uid')) ou s') = (ou = outOK \<and> (uid,uid') = (uidd,uidd'))"
|
"SFD uidd uidd' _ = False"

definition proper1 :: "(state,act,out) trans trace \<Rightarrow> bool" where
"proper1 tr \<equiv>
 \<exists> trr trnn tr3. tr = trr @ trnn # tr3 \<and>
                 (SFC UID UID' trnn \<or> SFC UID' UID trnn) \<and>
                 never (SFD UID UID') tr3 \<and> never (SFD UID' UID) tr3"

lemma SFC_validTrans:
assumes "validTrans trn"
and "\<not> UID' \<in>\<in> friendIDs (srcOf trn) UID"
and "UID' \<in>\<in> friendIDs (tgtOf trn) UID"
shows "SFC UID UID' trn \<or> SFC UID' UID trn"
proof(cases trn)
  case (Trans s a ou s')
  then show ?thesis
    using assms
    by (cases a) (auto elim: step_elims simp: all_defs)
qed

lemma SFD_validTrans:
assumes "validTrans trn"
and "UID' \<in>\<in> friendIDs (tgtOf trn) UID"
shows "\<not> SFD UID UID' trn \<and> \<not> SFD UID' UID trn"
proof(cases trn)
  case (Trans s a ou s')
  then show ?thesis
    using assms
    by (cases a) (auto elim: step_elims simp: all_defs)
qed

lemma SFC_SFD:
assumes "SFC uid1 uid2 trn" shows "\<not> SFD uid3 uid4 trn"
proof(cases trn)
  case (Trans s a ou s') note trn = Trans
  show ?thesis using assms unfolding trn
  by (cases "a") auto
qed

lemma proper1_valid:
assumes "valid tr"
and "\<not> UID' \<in>\<in> friendIDs (srcOf (hd tr)) UID"
and "UID' \<in>\<in> friendIDs (tgtOf (last tr)) UID"
shows "proper1 tr"
using assms unfolding valid_valid2 proof induct
  case (Singl trn)
  then show ?case unfolding proper1_def using SFC_validTrans
  by (intro exI[of _ "[]"] exI[of _ trn]) auto
next
  case (Rcons tr trn)
  show ?case
  proof(cases "UID' \<in>\<in> friendIDs (srcOf trn) UID")
    case False
    hence "SFC UID UID' trn \<or> SFC UID' UID trn"
    using Rcons SFC_validTrans by auto
    thus ?thesis unfolding proper1_def
    apply - apply (rule exI[of _ tr]) by (intro exI[of _ trn] exI[of _ "[]"]) auto
  next
    case True
    hence "proper1 tr" using Rcons by auto
    then obtain trr trnn tr3 where
    tr: "tr = trr @ trnn # tr3" and
    SFC: "SFC UID UID' trnn \<or> SFC UID' UID trnn" and
    n: "never (SFD UID UID') tr3 \<and> never (SFD UID' UID) tr3"
    unfolding proper1_def by auto
    have "UID' \<in>\<in> friendIDs (tgtOf trn) UID" using Rcons.prems(2) by auto
    hence SFD: "\<not> SFD UID UID' trn \<and> \<not> SFD UID' UID trn"
    using SFD_validTrans \<open>validTrans trn\<close> by auto
    show ?thesis using SFC n SFD unfolding proper1_def tr
    apply - apply (rule exI[of _ trr])
    by (intro exI[of _ trnn] exI[of _ "tr3 ## trn"]) simp
  qed
qed

lemma istate_friendIDs:
"\<not> UID' \<in>\<in> friendIDs (istate) UID"
unfolding istate_def by simp

lemma proper1_valid_istate:
assumes "valid tr" and "srcOf (hd tr) = istate"
and "UID' \<in>\<in> friendIDs (tgtOf (last tr)) UID"
shows "proper1 tr"
using assms istate_friendIDs proper1_valid by auto

(*  *)

definition proper2 :: "userID \<Rightarrow> userID \<Rightarrow> (state,act,out) trans trace \<Rightarrow> bool" where
"proper2 uid uid' tr \<equiv>
 \<exists> tr1 trnn tr2. tr = tr1 @ trnn # tr2 \<and> SFRC uid uid' trnn"

lemma SFRC_validTrans:
assumes "validTrans trn"
and "\<not> uid \<in>\<in> pendingFReqs (srcOf trn) uid'"
and "uid \<in>\<in> pendingFReqs (tgtOf trn) uid'"
shows "SFRC uid uid' trn"
proof(cases trn)
  case (Trans s a ou s')
  then show ?thesis
    using assms
    by (cases "a") (auto elim: step_elims simp: all_defs)
qed

lemma proper2_valid:
assumes "valid tr"
and "\<not> uid \<in>\<in> pendingFReqs (srcOf (hd tr)) uid'"
and "uid \<in>\<in> pendingFReqs (tgtOf (last tr)) uid'"
shows "proper2 uid uid' tr"
using assms unfolding valid_valid2 proof induct
  case (Singl trn)
  thus ?case unfolding proper2_def using SFRC_validTrans
  by (intro exI[of _ "[]"] exI[of _ trn]) auto
next
  case (Rcons tr trn)
  show ?case
  proof(cases "uid \<in>\<in> pendingFReqs (srcOf trn) uid'")
    case False
    hence "SFRC uid uid' trn"
    using Rcons SFRC_validTrans by auto
    thus ?thesis unfolding proper2_def
    apply - apply (rule exI[of _ tr]) by (intro exI[of _ trn] exI[of _ "[]"]) auto
  next
    case True
    hence "proper2 uid uid' tr" using Rcons by auto
    then obtain trr trnn tr3 where
    tr: "tr = trr @ trnn # tr3" and SFRC: "SFRC uid uid' trnn"
    unfolding proper2_def by auto
    have "uid \<in>\<in> pendingFReqs (tgtOf trn) uid'" using Rcons.prems(2) by auto
    show ?thesis using SFRC unfolding proper2_def tr
    apply - apply (rule exI[of _ trr])
    by (intro exI[of _ trnn] exI[of _ "tr3 ## trn"]) simp
  qed
qed

lemma istate_pendingFReqs:
"\<not> uid \<in>\<in> pendingFReqs (istate) uid'"
unfolding istate_def by simp

lemma proper2_valid_istate:
assumes "valid tr" and "srcOf (hd tr) = istate"
and "uid \<in>\<in> pendingFReqs (tgtOf (last tr)) uid'"
shows "proper2 uid uid' tr"
using assms istate_pendingFReqs proper2_valid by auto

(*  *)

lemma SFC_pendingFReqs:
assumes "validTrans trn"
and "SFC uid' uid trn"
shows "uid \<in>\<in> pendingFReqs (srcOf trn) uid'"
proof(cases trn)
  case (Trans s a ou s')
  then show ?thesis
    using assms
    by (cases "a") (auto elim: step_elims simp: all_defs)
qed

definition proper :: "(state,act,out) trans trace \<Rightarrow> bool" where
"proper tr \<equiv>
 \<exists> tr1 trn tr2 trnn tr3. tr = tr1 @ trn # tr2 @ trnn # tr3 \<and>
                 (SFRC UID' UID trn \<and> SFC UID UID' trnn \<or>
                  SFRC UID UID' trn \<and> SFC UID' UID trnn) \<and>
                 never (SFD UID UID') tr3 \<and> never (SFD UID' UID) tr3"

theorem friend_accountability:
assumes v: "valid tr" and i: "srcOf (hd tr) = istate"
and UID: "UID' \<in>\<in> friendIDs (tgtOf (last tr)) UID"
shows "proper tr"
proof-
  have "proper1 tr" using proper1_valid_istate[OF assms] .
  then obtain trr trnn tr3 where
  tr: "tr = trr @ trnn # tr3" and
  SFC: "SFC UID UID' trnn \<or> SFC UID' UID trnn" (is "?A \<or> ?B") and
  n: "never (SFD UID UID') tr3 \<and> never (SFD UID' UID) tr3"
  unfolding proper1_def by auto
  have trnn: "validTrans trnn" and trr: "valid trr" using tr
  apply (metis valid_Cons_iff append_self_conv2 assms(1) list.distinct(1) valid_append)
  by (metis SFC SFC_pendingFReqs append_self_conv2 i istate_pendingFReqs list.distinct(1) list.sel(1) tr v valid_Cons_iff valid_append)
  show ?thesis using SFC proof
    assume SFC: ?A
    have 0: "UID' \<in>\<in> pendingFReqs (srcOf trnn) UID"
    using SFC_pendingFReqs[OF trnn SFC] .
    hence "srcOf trnn \<noteq> istate" unfolding istate_def by auto
    hence 2: "trr \<noteq> []" using i unfolding tr by auto
    hence i: "srcOf (hd trr) = istate" using i unfolding tr by auto
    have "srcOf trnn = tgtOf (last trr)" using tr v valid_append 2 by auto
    hence 1: "UID' \<in>\<in> pendingFReqs (tgtOf (last trr)) UID" using 0 by simp
    have "proper2 UID' UID trr" using proper2_valid_istate[OF trr i 1] .
    then obtain tr1 trn tr2 where
    trr: "trr = tr1 @ trn # tr2" and SFRC: "SFRC UID' UID trn"
    unfolding proper2_def by auto
    show ?thesis unfolding proper_def
    apply(rule exI[of _ tr1], rule exI[of _ trn], rule exI[of _ tr2],
          rule exI[of _ trnn], rule exI[of _ tr3])
    unfolding tr trr using SFRC SFC n by simp
  next
    assume SFC: ?B
    have 0: "UID \<in>\<in> pendingFReqs (srcOf trnn) UID'"
    using SFC_pendingFReqs[OF trnn SFC] .
    hence "srcOf trnn \<noteq> istate" unfolding istate_def by auto
    hence 2: "trr \<noteq> []" using i unfolding tr by auto
    hence i: "srcOf (hd trr) = istate" using i unfolding tr by auto
    have "srcOf trnn = tgtOf (last trr)" using tr v valid_append 2 by auto
    hence 1: "UID \<in>\<in> pendingFReqs (tgtOf (last trr)) UID'" using 0 by simp
    have "proper2 UID UID' trr" using proper2_valid_istate[OF trr i 1] .
    then obtain tr1 trn tr2 where
    trr: "trr = tr1 @ trn # tr2" and SFRC: "SFRC UID UID' trn"
    unfolding proper2_def by auto
    show ?thesis unfolding proper_def
    apply(rule exI[of _ tr1], rule exI[of _ trn], rule exI[of _ tr2],
          rule exI[of _ trnn], rule exI[of _ tr3])
    unfolding tr trr using SFRC SFC n by simp
  qed
qed

end


theory Eq
imports Base
begin

chapter \<open>Equational reasoning\<close>

text \<open>Equality is one of the most fundamental concepts of
  mathematics.  The Isabelle/Pure logic (\chref{ch:logic}) provides a
  builtin relation @{text "\<equiv> :: \<alpha> \<Rightarrow> \<alpha> \<Rightarrow> prop"} that expresses equality
  of arbitrary terms (or propositions) at the framework level, as
  expressed by certain basic inference rules (\secref{sec:eq-rules}).

  Equational reasoning means to replace equals by equals, using
  reflexivity and transitivity to form chains of replacement steps,
  and congruence rules to access sub-structures.  Conversions
  (\secref{sec:conv}) provide a convenient framework to compose basic
  equational steps to build specific equational reasoning tools.

  Higher-order matching is able to provide suitable instantiations for
  giving equality rules, which leads to the versatile concept of
  @{text "\<lambda>"}-term rewriting (\secref{sec:rewriting}).  Internally
  this is based on the general-purpose Simplifier engine of Isabelle,
  which is more specific and more efficient than plain conversions.

  Object-logics usually introduce specific notions of equality or
  equivalence, and relate it with the Pure equality.  This enables to
  re-use the Pure tools for equational reasoning for particular
  object-logic connectives as well.
\<close>

section \<open>Basic equality rules \label{sec:eq-rules}\<close>

text \<open>Isabelle/Pure uses @{text "\<equiv>"} for equality of arbitrary
  terms, which includes equivalence of propositions of the logical
  framework.  The conceptual axiomatization of the constant @{text "\<equiv>
  :: \<alpha> \<Rightarrow> \<alpha> \<Rightarrow> prop"} is given in \figref{fig:pure-equality}.  The
  inference kernel presents slightly different equality rules, which
  may be understood as derived rules from this minimal axiomatization.
  The Pure theory also provides some theorems that express the same
  reasoning schemes as theorems that can be composed like object-level
  rules as explained in \secref{sec:obj-rules}.

  For example, @{ML Thm.symmetric} as Pure inference is an ML function
  that maps a theorem @{text "th"} stating @{text "t \<equiv> u"} to one
  stating @{text "u \<equiv> t"}.  In contrast, @{thm [source]
  Pure.symmetric} as Pure theorem expresses the same reasoning in
  declarative form.  If used like @{text "th [THEN Pure.symmetric]"}
  in Isar source notation, it achieves a similar effect as the ML
  inference function, although the rule attribute @{attribute THEN} or
  ML operator @{ML "op RS"} involve the full machinery of higher-order
  unification (modulo @{text "\<beta>\<eta>"}-conversion) and lifting of @{text
  "\<And>/\<Longrightarrow>"} contexts.\<close>

text %mlref \<open>
  \begin{mldecls}
  @{index_ML Thm.reflexive: "cterm -> thm"} \\
  @{index_ML Thm.symmetric: "thm -> thm"} \\
  @{index_ML Thm.transitive: "thm -> thm -> thm"} \\
  @{index_ML Thm.abstract_rule: "string -> cterm -> thm -> thm"} \\
  @{index_ML Thm.combination: "thm -> thm -> thm"} \\[0.5ex]
  @{index_ML Thm.equal_intr: "thm -> thm -> thm"} \\
  @{index_ML Thm.equal_elim: "thm -> thm -> thm"} \\
  \end{mldecls}

  See also @{file "~~/src/Pure/thm.ML" } for further description of
  these inference rules, and a few more for primitive @{text "\<beta>"} and
  @{text "\<eta>"} conversions.  Note that @{text "\<alpha>"} conversion is
  implicit due to the representation of terms with de-Bruijn indices
  (\secref{sec:terms}).\<close>

section \<open>Conversions \label{sec:conv}\<close>

text \<open>
  %FIXME

  The classic article that introduces the concept of conversion (for
  Cambridge LCF) is @{cite "paulson:1983"}.
\<close>

section \<open>Rewriting \label{sec:rewriting}\<close>

text \<open>Rewriting normalizes a given term (theorem or goal) by
  replacing instances of given equalities @{text "t \<equiv> u"} in subterms.
  Rewriting continues until no rewrites are applicable to any subterm.
  This may be used to unfold simple definitions of the form @{text "f
  x\<^sub>1 \<dots> x\<^sub>n \<equiv> u"}, but is slightly more general than that.
\<close>

text %mlref \<open>
  \begin{mldecls}
  @{index_ML rewrite_rule: "Proof.context -> thm list -> thm -> thm"} \\
  @{index_ML rewrite_goals_rule: "Proof.context -> thm list -> thm -> thm"} \\
  @{index_ML rewrite_goal_tac: "Proof.context -> thm list -> int -> tactic"} \\
  @{index_ML rewrite_goals_tac: "Proof.context -> thm list -> tactic"} \\
  @{index_ML fold_goals_tac: "Proof.context -> thm list -> tactic"} \\
  \end{mldecls}

  \begin{description}

  \item @{ML rewrite_rule}~@{text "ctxt rules thm"} rewrites the whole
  theorem by the given rules.

  \item @{ML rewrite_goals_rule}~@{text "ctxt rules thm"} rewrites the
  outer premises of the given theorem.  Interpreting the same as a
  goal state (\secref{sec:tactical-goals}) it means to rewrite all
  subgoals (in the same manner as @{ML rewrite_goals_tac}).

  \item @{ML rewrite_goal_tac}~@{text "ctxt rules i"} rewrites subgoal
  @{text "i"} by the given rewrite rules.

  \item @{ML rewrite_goals_tac}~@{text "ctxt rules"} rewrites all subgoals
  by the given rewrite rules.

  \item @{ML fold_goals_tac}~@{text "ctxt rules"} essentially uses @{ML
  rewrite_goals_tac} with the symmetric form of each member of @{text
  "rules"}, re-ordered to fold longer expression first.  This supports
  to idea to fold primitive definitions that appear in expended form
  in the proof state.

  \end{description}
\<close>

end