(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory WPTutorial
imports "../proof/refine/$L4V_ARCH/Bits_R"
begin

text {*
This is a tutorial on the use of the various Hoare mechanisms developed
for the L4.verified project. We import Bits_R above, which is a compromise
between the twin goals of getting the Hoare setup from L4.verified and not
importing existing properties. It's probably best to work from a prebuilt
REFINE_S or REFINE Isabelle image which includes Bits_R.
*}

text {* The point of our apparatus is to prove Hoare triples. These are a
triple of a precondition, function and postcondition. In our state-monadic
world, the precondition is a function of the state, and the postcondition
is a function of the return value and the state. In example 1 below,
the precondition doesn't impose any restriction on the state, and the
postcondition only requires that the return value be the obvious one. *}

text {* The weakest precondition tool, wp, attempts to construct the
weakest precondition for a given postcondition. Use wp (with the command
"apply wp") to solve example 1 *}

lemma example_1:
  "\<lbrace>\<lambda>s. True\<rbrace> return 1 \<lbrace>\<lambda>rv s. rv = 1\<rbrace>"
  apply wp
  apply simp
  done

text {* The wp tool works in reverse order (from postcondition to weakest
precondition, rather than from precondition to strongest postcondition).
It stops when it encounters a postcondition/function pair it doesn't
know any rules for. Try example 2 below, noting where wp gets stuck.

The wp method already knows how to handle most monadic operations
(liftE, catch, assert, when, if-then-else, etc) but there are some
exceptions. One is the split operator, which hides behind Isabelle syntax
that looks like (\<lambda>(x, y). blah), {(x, y). blah}, (\<forall>(x, y) \<in> S. blah).
Solve the problem by unfolding it with (simp add: split_def).

The intermediate precondition seen when wp stops is a schematic variable.
The wp tool uses Isabelle's underlying unification mechanism to set the
precondition as it goes. This usually works well, but there are some
problems, especially with tuples. Note the strange behaviour if we use
clarsimp instead of (simp add: split_def) to deal with the split constant.
The root cause of this strange behaviour is that the unification mechanism
does not know how to construct a ?P such that "?P (a, b) = a". This is
annoying, since it means that clarsimp/clarify/safe must frequently be
avoided.
*}

lemma example_2:
  "\<lbrace>\<lambda>s. s = [(True, False), (False, True)]\<rbrace> do
     v \<leftarrow> gets length;
     (x, y) \<leftarrow> gets hd;
     return x
   od \<lbrace>\<lambda>rv s. rv\<rbrace>"
  apply wp
  apply (simp add: split_def)
  apply wp
  apply simp
  done

text {*
An additional annoyance to the clarsimp/tuple issue described above is
the splitter. The wp tool is designed to work on a hoare triple with a
schematic precondition. Note how the simplifier splits the problem
in two because it contains an if constant. Delete the split
rule from the simpset with (simp split del: if_split) to avoid this
issue and see where wp gets stuck.

We still need to deal with the if constant. In this (somewhat contrived)
example we can give the simplifier the rule if_apply_def2 to make
progress.

Note that wp can deal with a function it knows nothing about if
the postcondition is constant in the return value and state.
*}

lemma example_3:
  "\<lbrace>\<lambda>s. s = [False, True]\<rbrace> do
     x \<leftarrow> gets hd;
     possible_state_change_that_isnt_defined;
     y \<leftarrow> gets (if x then \<bottom> else \<top>);
     return $ y \<and> \<not> x
   od \<lbrace>\<lambda>rv s. rv\<rbrace>"
  apply wp
  apply (simp add: if_apply_def2 split del: if_split)
  apply wp
  apply simp
  done

text {* Let's make this more interesting by introducing some functions
from the abstract specification. The set_endpoint function is used to
set the contents of an endpoint object somewhere in the kernel object
heap (kheap). The cap derivation tree (cdt) lives in an entirely
different field of the state to the kheap, so this fact about it should
be unchanged by the endpoint update. Solve example 4 - you'll have to
unfold enough definitions that wp knows what to do. *}

lemma example_4:
  "\<lbrace>\<lambda>s. cdt s (42, [True, False]) = None\<rbrace>
      set_endpoint ptr Structures_A.IdleEP
   \<lbrace>\<lambda>rv s. cdt s (42, [True, False]) = None\<rbrace>"
  apply (simp add: set_endpoint_def set_object_def get_object_def)
  apply wp
  apply clarsimp
  done

text {*
Example 4 proved that a property about the cdt was preserved from
before set_endpoint to after. This preservation property is true for
any property that just talks about the cdt. Example 5 rephrases
example 4 in this style. Get used to this style of Hoare triple,
it is very common in our proofs.
*}

lemma example_5:
  "\<lbrace>\<lambda>s. P (cdt s)\<rbrace>
      set_endpoint ptr Structures_A.IdleEP
   \<lbrace>\<lambda>rv s. P (cdt s)\<rbrace>"
  apply (simp add: set_endpoint_def set_object_def get_object_def)
  apply wp
  apply clarsimp
  done

text {*
The set_cap function from the abstract specification is not much different
to set_endpoint. However, caps can live within CSpace objects or within
TCBs, and the set_cap function handles this issue with a case division.

The wp tool doesn't know anything about how to deal with case statements.
In addition to the tricks we've learned already, use the wpc tool to break
up the case statement into components so that wp can deal with it to solve
example 6.
*}

lemma example_6:
  "\<lbrace>\<lambda>s. P (cdt s)\<rbrace>
     set_cap cap ptr
   \<lbrace>\<lambda>rv s. P (cdt s)\<rbrace>"
  apply (simp add: set_cap_def split_def set_object_def
                   get_object_def)
  apply (wp | wpc)+
  apply simp
  done

text {*
The wp method can be given additional arguments which are theorems to use
as summaries. Solve example 7 by supplying example 6 as a rule to
use with (wp example_6).
*}

lemma example_7:
  "\<lbrace>\<lambda>s. cdt s ptr' = None\<rbrace> do
     set_cap cap.NullCap ptr;
     v \<leftarrow> gets (\<lambda>s. cdt s ptr);
     assert (v = None);
     set_cap cap.NullCap ptr';
     set_cap cap.IRQControlCap ptr';
     return True
   od \<lbrace>\<lambda>rv s. cdt s ptr = None \<and> cdt s ptr' = None\<rbrace>"
  apply (wp example_6)
  apply simp
  done

text {*
There isn't a good reason not to use example_6 whenever possible, so we can
declare example_6 a member of the wp rule set by changing its proof site to
"lemma example_6[wp]:", by doing "declare example_6[wp]", or by putting it
in a group of lemmas declared wp with "lemmas foo[wp] = example_6".
Pick one of those options and remove the manual reference to example_6 from
the proof of example_7.
*}

text {*
These preservation Hoare triples are often easy to prove and apply, so much
of the effort is in typing them all out. To speed this up we have the crunch
tool. Let's prove that setup_reply_master and set_endpoint don't change
another field of the state, machine_state. I've typed out the required
crunch command below. Let's explain the bits. The naming scheme
"machine_state_preserved:" sets a common suffix for all the lemmas
proved. Just like with lemma names, we could add the theorems to the wp set
with "machine_state_preserved[wp]:". What follows is a list of functions.
The crunch tool also descends through the call graph of functions, so it
proves a rule about set_cap because setup_reply_master calls it. The last
argument is the term to appear in the precondition and postcondition.

The final, optional bit of the crunch syntax is a group of modifiers, which
go between the parentheses inserted below. The crunch command doesn't
currently work. We need to provide some additional simp and wp rules
with syntax like (simp: some rules wp: some rules). If you look at the way
crunch failed, you'll spot which simp rule we need to add to make some
progress.

But not much more progress. To get through set_endpoint, we need to deal
with a slightly complex postcondition to get_object, one which incorporates
an assertion about its return value. We can solve this problem by simply
throwing the extra assumption away - supplying the wp rule hoare_drop_imps
does this. There are standard sets of simp and wp rules which are frequently
helpful to crunch, crunch_simps and crunch_wps, which contain the rules we
added here.
*}

crunch machine_state_preserved:
  setup_reply_master, set_endpoint
    "\<lambda>s. P (machine_state s)"
  (simp: split_def wp: crunch_wps)

text {*
We're making progress in solving simple problems here. It's time to
introduce some more complicated predicates, and explain the remaining
features of wp.
*}

end


section \<open>Introduction to IMP2-VCG, based on IMP\<close>
theory IMP2_from_IMP
imports "../IMP2"
begin

  text \<open>This document briefly introduces the extensions of IMP2 over IMP.\<close>

  subsection \<open>Fancy Syntax\<close>

  text \<open>Standard Syntax\<close>
  definition "exp_count_up1 \<equiv>
    ''a'' ::= N 1;;
    ''c'' ::= N 0;;
    WHILE Cmpop (<) (V ''c'') (V ''n'') DO (
      ''a'' ::= Binop (*) (N 2) (V ''a'');;
      ''c'' ::= Binop (+) (V ''c'') (N 1))"

  (* Type \ < ^ imp > \open \close , without the spaces.

    for \<open>\<dots>\<close>, there is an autocompletion if you type a quote (")

    for \<comment> \<open>\<close>, type \comment and use autocompletion

  *)
  text \<open>Fancy Syntax\<close>
  definition "exp_count_up2 \<equiv> \<^imp>\<open>
    \<comment> \<open>Initialization\<close>
    a = 1;
    c = 0;
    while (c<n) { \<comment> \<open>Iterate until \<open>c\<close> has reached \<open>n\<close>\<close>
      a=2*a; \<comment> \<open>Double \<open>a\<close>\<close>
      c=c+1  \<comment> \<open>Increment \<open>c\<close>\<close>
    }
  \<close>"

  lemma "exp_count_up1 = exp_count_up2"
    unfolding exp_count_up1_def exp_count_up2_def ..

  subsection \<open>Operators and Arrays\<close>

  text \<open>We reflect arbitrary Isabelle functions into the syntax: \<close>
  value "bval (Cmpop (\<le>) (Binop (+) (Unop uminus (V ''x'')) (N 42)) (N 50)) <''x'':=(\<lambda>_. -5)> "

  thm aval.simps bval.simps

  text \<open>Every variable is an array, indexed by integers, no bounds.
    Syntax shortcuts to access index 0.
  \<close>

  term \<open>Vidx ''a'' (i::aexp)\<close> \<comment> \<open>Array access at index \<open>i\<close>\<close>
  lemma "V ''x'' = Vidx ''x'' (N 0)" .. \<comment> \<open>Shortcut for access at index \<open>0\<close>\<close>

  text \<open>New commands:\<close>
  term \<open>AssignIdx ''a'' (i::aexp) (v::aexp)\<close> \<comment> \<open>Assign at index. Replaces assign.\<close>
  term \<open>''a''[i] ::= v\<close>  \<comment> \<open>Standard syntax\<close>
  term \<open>\<^imp>\<open> a[i] = v \<close>\<close> \<comment> \<open>Fancy syntax\<close>

  lemma \<open>Assign ''x'' v = AssignIdx ''x'' (N 0) v\<close> .. \<comment> \<open>Shortcut for assignment to index \<open>0\<close>\<close>
  term \<open>''x'' ::= v\<close> term \<open>\<^imp>\<open>x = v+1\<close>\<close>

  text \<open>Note: In fancy syntax, assignment between variables is always parsed as array copy.
    This is no problem unless a variable is used as both, array and plain value,
    which should be avoided anyway.
  \<close>

  term \<open>ArrayCpy ''d'' ''s''\<close> \<comment> \<open>Copy whole array. Both operands are variable names.\<close>
  term \<open>''d''[] ::= ''s''\<close> term \<open>\<^imp>\<open>d = s\<close>\<close>

  term \<open>ArrayClear ''a''\<close> \<comment> \<open>Initialize array to all zeroes.\<close>
  term \<open>CLEAR ''a''[]\<close> term \<open>\<^imp>\<open>clear a[]\<close>\<close>

  text \<open>Semantics of these is straightforward\<close>
  thm big_step.AssignIdx big_step.ArrayCpy big_step.ArrayClear

  subsection \<open>Local and Global Variables\<close>
  term \<open>is_global\<close> term \<open>is_local\<close> \<comment> \<open>Partitions variable names\<close>
  term \<open><s\<^sub>1|s\<^sub>2>\<close> \<comment> \<open>State with locals from \<open>s\<^sub>1\<close> and globals from \<open>s\<^sub>2\<close>\<close>

  term \<open>SCOPE c\<close> term \<open>\<^imp>\<open>scope { skip }\<close>\<close>    \<comment> \<open>Execute \<open>c\<close> with fresh set of local variables\<close>
  thm big_step.Scope

  subsubsection \<open>Parameter Passing\<close>
  text \<open>Parameters and return values by global variables: This is syntactic sugar only:\<close>
  context fixes f :: com begin
  term \<open>\<^imp>\<open> (r1,r2) = f(x1,x2,x3)\<close>\<close>
  end

  subsection \<open>Recursive procedures\<close>
  term \<open>PCall ''name''\<close>
  thm big_step.PCall

  subsubsection \<open>Procedure Scope\<close>
  text \<open>Execute command with local set of procedures\<close>
  term \<open>PScope \<pi> c\<close>
  thm big_step.PScope

  subsubsection \<open>Syntactic sugar for procedure call with parameters\<close>
  term \<open>\<^imp>\<open>(r1,r2) = rec name(x1,x2,x3)\<close>\<close>

  subsection \<open>More Readable VCs\<close>
  lemmas nat_distribs = nat_add_distrib nat_diff_distrib Suc_diff_le nat_mult_distrib nat_div_distrib

  lemma "s\<^sub>0 ''n'' 0 \<ge> 0 \<Longrightarrow> wlp \<pi> exp_count_up1 (\<lambda>s. s ''a'' 0 = 2^nat (s\<^sub>0 ''n'' 0)) s\<^sub>0"
    unfolding exp_count_up1_def
    apply (subst annotate_whileI[where
          I="\<lambda>s. s ''n'' 0 = s\<^sub>0 ''n'' 0 \<and>  s ''a'' 0 = 2 ^ nat (s ''c'' 0) \<and> 0 \<le> s ''c'' 0 \<and> s ''c'' 0 \<le> s\<^sub>0 ''n'' 0"
        ])
    apply (i_vcg_preprocess; i_vcg_gen; clarsimp)
    text \<open>The postprocessor converts from states applied to string names to actual variables\<close>
    apply i_vcg_postprocess
    by (auto simp: algebra_simps nat_distribs)

  lemma "s\<^sub>0 ''n'' 0 \<ge> 0 \<Longrightarrow> wlp \<pi> exp_count_up1 (\<lambda>s. s ''a'' 0 = 2^nat (s\<^sub>0 ''n'' 0)) s\<^sub>0"
    unfolding exp_count_up1_def
    apply (subst annotate_whileI[where
          I="\<lambda>s. s ''n'' 0 = s\<^sub>0 ''n'' 0 \<and>  s ''a'' 0 = 2 ^ nat (s ''c'' 0) \<and> 0 \<le> s ''c'' 0 \<and> s ''c'' 0 \<le> s\<^sub>0 ''n'' 0"
        ])
    text \<open>The postprocessor is invoked by default\<close>
    apply vcg
    oops

  subsection \<open>Specification Commands\<close>

  text \<open>IMP2 provides a set of commands to simplify specification and annotation of programs.\<close>

  text \<open>Old way of proving a specification: \<close>
  lemma "let n = s\<^sub>0 ''n'' 0 in n \<ge> 0
    \<Longrightarrow> wlp \<pi> exp_count_up1 (\<lambda>s. let a = s ''a'' 0; n\<^sub>0 = s\<^sub>0 ''n'' 0 in a = 2^nat (n\<^sub>0)) s\<^sub>0"
    unfolding exp_count_up1_def
    apply (subst annotate_whileI[where
          I="\<lambda>s. s ''n'' 0 = s\<^sub>0 ''n'' 0 \<and>  s ''a'' 0 = 2 ^ nat (s ''c'' 0) \<and> 0 \<le> s ''c'' 0 \<and> s ''c'' 0 \<le> s\<^sub>0 ''n'' 0"
          (* Similar for invar! *)
        ])
    apply vcg
    apply (auto simp: algebra_simps nat_distribs)
    done

  lemma "VAR (s x) P = (let v=s x in P v)" unfolding VAR_def by simp

  text \<open>IMP2 specification commands\<close>
  program_spec (partial) exp_count_up
    assumes "0\<le>n"               \<comment> \<open>Precondition. Use variable names of program.\<close>
    ensures "a = 2^nat n\<^sub>0"       \<comment> \<open>Postcondition. Use variable names of programs.
                                      Suffix with \<open>\<cdot>\<^sub>0\<close> to refer to initial state\<close>
    defines                     \<comment> \<open>Program\<close>
    \<open>
      a = 1;
      c = 0;
      while (c<n)
        @invariant \<open>n=n\<^sub>0 \<and> a=2^nat c \<and> 0\<le>c \<and> c\<le>n\<close> \<comment> \<open>
            Invar annotation. Variable names and suffix \<open>\<cdot>\<^sub>0\<close> for variables from initial state.\<close>
      {
        a=2*a;
        c=c+1
      }
    \<close>
    apply vcg
    by (auto simp: algebra_simps nat_distribs)

  thm exp_count_up_spec
  thm exp_count_up_def

  (*
    We can also annotate
      @variant \<open>measure-expression\<close>
        (interpreted over variables (v) and variables at program start (v\<^sub>0)

    or, both @variant \<open>\<dots>\<close> and @relation \<open>R\<close>:
      R :: 'a rel, and variant produces an 'a

  *)

  procedure_spec exp_count_up_proc(n) returns a
    assumes "0\<le>n"
    ensures "a = 2^nat n\<^sub>0"
    defines
    \<open>
      a = 1;
      c = 0;
      while (c<n)
        @invariant \<open>n=n\<^sub>0 \<and> a=2^nat c \<and> 0\<le>c \<and> c\<le>n\<close>
        @variant \<open>n-c\<close>
      {
        a=2*a;
        c=c+1
      }
    \<close>
    apply vcg
    by (auto simp: algebra_simps nat_distribs)

  text \<open>Simple Recursion\<close>
  recursive_spec
    exp_rec(n) returns a assumes "0\<le>n" ensures "a=2^nat n\<^sub>0" variant "n"
    defines \<open>if (n==0) a=1 else {t=rec exp_rec(n-1); a=2*t}\<close>
    apply vcg
      apply (auto simp: algebra_simps nat_distribs)
    by (metis Suc_le_D diff_Suc_Suc dvd_1_left dvd_imp_le minus_nat.diff_0 nat_0_iff nat_int neq0_conv of_nat_0 order_class.order.antisym pos_int_cases power_Suc zless_nat_eq_int_zless)

  text \<open>Mutual Recursion: See Examples\<close>

end


(* header\<open> Teorema de existencia de models proposicionales \<close> *)

(*<*)
theory T5CCerradaIngles
imports T1SintaxisSemanticaIngles T2NotacionUniformeIngles
begin
(*>*)

text \<open>
  \label{cap6}
\<close>

section\<open> Teorema de Existencia de Modelos \<close>
text \<open>
  \label{consistcerradoP}
   Un método de
  demostración, utilizado por el lógico Leon Henkin, para demostrar la completitud
  de un sistema de deducción es considerar la
  afirmación contrarrecíproca, es decir, si una fórmula $F$ no es
  deducible entonces no es tautología. La prueba utiliza el siguiente
  teorema que hace referencia a la noción de {\em consistencia}.  Una
  fórmula $F$ es consistente, con respecto al cálculo de prueba
  $\vdash$, si $\nvdash \neg F$; es decir, si $\neg F$ no es deducible
  en el sistema.

  \begin{teorema}[Henkin]\label{Henkin}
  Para cualquier fórmula $F$, Si $F$ es consistente entonces $F$ tiene
  un model.
  \end{teorema}

  Como una consecuencia del teorema anterior podemos demostrar que
  el sistema deductivo es completo. Consideremos una fórmu\-la $F$
  que no es deducible, $\nvdash F$. Además supongamos que
  $\vdash \neg \neg F \rightarrow F$. Entonces, de la
  hipótesis $\nvdash F$ y por la regla MP tene\-mos que $\nvdash \neg \neg F$,
  es decir, $\nvdash \neg (\neg F)$. De esta forma, $\neg F$ es
  consistente. Luego, por el teorema \ref{Henkin}, $\neg F$ tiene un
  model. Por lo tanto, $F$ no es tautología.

  Para demostrar el teorema \ref{Henkin}, se extiende la noción de
  consistencia de una fórmu\-la a un conjunto de fórmulas.  Un conjunto
  finito de fórmulas $S = \{F_1, F_2,\dots , F_n\}$ es consistente si la
  fórmula $F_1\wedge F_2\wedge \dots \wedge F_n$ es consistente, es
  decir $\nvdash \neg(F_1\wedge F_2\wedge \dots \wedge F_n)$. Un
  conjunto arbitrario de fórmulas $S$ es consistente si cada subconjunto
  finito de $S$ es consistente.

  Un conjunto consistente de fórmulas $S$ es un {\em conjunto
  consistente maximal} si para toda fórmula $F\notin S$, $S\cup\{F\}$ no
  es consistente.  Un resultado importante sobre estos conjuntos es el
  teorema de Lindenbaum:

  \begin{teorema}[Lindenbaum]\label{Lindenbaum}
  Todo conjunto consistente $S$ puede ser extendido a un conjunto
  consistente maximal $M$.
  \end{teorema}

  El conjunto $M$ se define, a partir de $S$ y de una @{text
  "enumeración"} $\phi_0$, $\phi_1$, $\phi_2$, $\ldots$ del conjunto de
  fórmulas del lenguaje proposicional, como la unión $\bigcup_i S_i$ de
  la siguiente sucesión $S_i$ de conjuntos consistentes:
  \[
  \begin{array}{l}
    S_0 = S \\
    S_{i+1} =
     \left\{
      \begin{array}{ll}
      S_i \cup \{\phi_i\} &
        \hbox{si } S_i \cup \{\phi_i\} \hbox{ es consistente} \\
      S_i &
        \hbox{en otro caso.}
      \end{array}
     \right.
  \end{array}
  \]

  Sea $M$ un conjunto consistente maximal. Para establecer la conexión
  entre conjuntos consistentes e interpretaciones, definimos la
  siguiente interpretación $I_M$.  Sea $P$ un símbolo proposicional,
  entonces
  \newline \hspace*{1cm}
    \[ I_M(P) =
       \begin{cases}
         \V, & \text{si $P\in M$} \\
         \F, & \text{en otro caso.}
       \end{cases} \]

  Se tiene el siguiente resultado.

  \begin{teorema}\label{preHintikka}
  Si $M$ es un conjunto consistente maximal, entonces para toda fórmula
  $F$, $I'_M(F)=\V$ si y solamente si $F\in M$.
  \end{teorema}

  Como una consecuencia del teorema anterior se tiene la demostración
  del teorema \ref{Henkin}:

  \begin{demostracion}
  Sea $F$ una fórmula consistente. Por el teorema \ref{Lindenbaum},
  $\{F\}$ puede extenderse a un conjunto consistente maximal $M$. Por el
  teorema \ref{preHintikka}, $I'_M(F)=\V$ puesto que $F\in M$. Es decir,
  $F$ tiene un model.
  \end{demostracion}

  Utilizando el concepto abstracto de conjunto consiste y siguiendo
  las ideas anteriores, de extender un conjunto consistente de fórmulas
  $S$ a un conjunto consistente maximal $M$,
  el desarrollo central de la demostración que aparece en el texto de
  Fitting, (\cite{Fitting} página 60), es el sigui\-ente.
  \begin{itemize}
  \item Usando la noción de @{text "clausura por subconjuntos"} se
    prueba que $M$ es maximal.
  \item Usando la noción de @{text "carácter finito"} se prueba que $M$
    es consistente.
  \end{itemize}

  Además se demuestran los siguientes dos resultados.
  \begin{itemize}
  \item Al ser $M$ un conjunto maximal de carácter finito es de  @{text "Hintikka"}.
  \item Los conjuntos de Hintikka son satisfiables.
  \end{itemize}

  Por tanto, se puede concluir que $M$ es satisfiable y, puesto que
  @{text "S \<subseteq> M"}, se tiene que $S$ también es satisfiable.
\<close>

subsection \<open> Conjuntos consistentes \<close>

text \<open>
  \label{conjuntosconsistentesP}
  En esta sección formalizamos el criterio abstracto, propuesto en
  (\cite{Fitting} página 59), para describir los conjuntos consistentes.

  \begin{definicion}\label{consistenciaP}
  Una colección de conjuntos de fórmulas $\mathcal{C}$ es una
  {\bf{propiedad de consistencia proposicional}}, si todo elemento
  $S$ de $\mathcal{C}$ verifica las siguien\-tes propiedades.
  \begin{enumerate}
  \item Para cualquier fórmula atómica $P$, $P\notin S$ o $\neg P \notin S$.
  \item $\bot\notin S$ y $\neg \top\notin S$.
  \item Si $\neg \neg F \in S$ entonces $S\cup \{F\}\in \mathcal{C}$.
  \item Si $\alpha \in S$ entonces, $S\cup\{\alpha_1,\alpha_2\}\in \mathcal{C}$.
  \item Si $\beta \in S$ entonces, $S\cup \{\beta_1\}\in \mathcal{C}$ o
    $S\cup \{\beta_2\}\in \mathcal{C}$.
  \end{enumerate}
  \end{definicion}

  \noindent Su formalización es:
\<close>

definition consistenceP :: "'b formula set set \<Rightarrow> bool" where
  "consistenceP \<C> =
     (\<forall>S. S \<in> \<C> \<longrightarrow> (\<forall>P. \<not> (atom P \<in> S \<and> (\<not>.atom P) \<in> S)) \<and>
     FF \<notin> S \<and> (\<not>.TT) \<notin> S \<and>
     (\<forall>F. (\<not>.\<not>.F) \<in> S \<longrightarrow> S \<union> {F} \<in>  \<C>) \<and>
     (\<forall>F. ((FormulaAlfa F) \<and> F\<in>S) \<longrightarrow> (S\<union>{Comp1 F, Comp2 F}) \<in> \<C>) \<and>
     (\<forall>F. ((FormulaBeta F) \<and> F\<in>S) \<longrightarrow> (S\<union>{Comp1 F}\<in>\<C>) \<or> (S\<union>{Comp2 F}\<in>\<C>)))"

subsection \<open> Conjuntos consistentes y clausura por subconjuntos \<close>

text \<open>
  \label{cerraduraP}
  \begin{definicion}\label{subcerrada}
  Una colección  de conjuntos $\mathcal{C}$ es {\bf{cerrada por
  subconjuntos}} si para cada $S\in\mathcal{C}$ los subconjuntos de $S$
  también son elementos de $\mathcal{C}$.
  \end{definicion}

  \noindent Su formalización es:
\<close>

definition subconj_cerrada :: "'a set set \<Rightarrow> bool" where
  "subconj_cerrada \<C> = (\<forall>S \<in> \<C>. \<forall>S'. S' \<subseteq> S \<longrightarrow> S' \<in> \<C>)"

text \<open>
  En esta sección demostraremos que toda propiedad de consistencia
  proposicional $\mathcal{C}$ puede extenderse a una propiedad de
  consistencia $\mathcal{C^{+}}$ que es cerrada por subconjuntos. Para
  la demostración basta con considerar $\mathcal{C^{+}}$ igual a la
  colección de los subconjuntos de los elementos de $\mathcal{C}$,
  \[\mathcal{C^{+}}=\{S| \exists S' \in \mathcal{C} (S \subseteq
  S')\}.\] La definición en Isabelle de $\mathcal{C^{+}}$ es,
\<close>

definition clausura_subconj :: "'a set set \<Rightarrow> 'a set set" ("_⁺"[1000] 1000) where
  "\<C>⁺ = {S. \<exists>S' \<in> \<C>. S \<subseteq> S'}"

text \<open>
  \begin{teorema}\label{CerraduraSubconjuntosP}\mbox{}
  \par\noindent
  Sea $\mathcal{C}$ una colección de conjuntos. entonces,
  \begin{itemize}
  \item[(a)] $\mathcal{C} \subseteq \mathcal{C^{+}}$.
  \item[(b)] $\mathcal{C^{+}}$ es cerrada por subconjuntos.
  \item[(c)] Si $\mathcal{C}$ es una propiedad de consistencia
    proposicional entonces $\mathcal{C^{+}}$ también es una propiedad de
    consistencia proposicional.
  \end{itemize}
  \end{teorema}
\<close>

text \<open>
  \begin{demostracion}
  \begin{itemize}
  \item[(a)] Sea  $S \in \mathcal{C}$. Puesto que $S \subseteq S$ se
    tiene que $S \in \mathcal{C^{+}}$ por la definición de
    $\mathcal{C^{+}}$. Por tanto $\mathcal{C}$ está contenido en
    $\mathcal{C^{+}}$.

  \item[(b)] Supongamos que $S \in \mathcal{C^{+}}$ y sea $T\subseteq
    S$. Puesto que $S \in \mathcal{C^{+}}$, existe $S'\in \mathcal{C}$
    tal que $S \subseteq S'$ por la definición de
    $\mathcal{C^{+}}$. Luego existe $S'\in \mathcal{C}$ tal que
    $T\subseteq S'$ y, por tanto, $T\in \mathcal{C^{+}}$. Así,
    $\mathcal{C^{+}}$ es una colección cerrada por subconjuntos.

  \item[(c)] Supongamos que $\mathcal{C}$ es una propiedad de
    consistencia proposicional.  Sea $S\in \mathcal{C^{+}}$, entonces
    existe $S'\in \mathcal{C}$ tal que $S\subseteq S'$, de esto último
    mostramos que se cumplen las condiciones para que $\mathcal{C^{+}}$
    sea una propiedad de consistencia.
  \end{itemize}
  \begin{enumerate}

  \item Sea $P$ una fórmula atómica, entonces $P\notin S'$ o $\neg P
    \notin S'$ ya que $S'\in \mathcal{C}$ y $\mathcal{C}$ es una
    propiedad de consistencia. Luego, $P\notin S$ o $\neg P \notin S$
    puesto que $S\subseteq S'$.

  \item $\bot\notin S'$ y $\neg \top \notin S'$ puesto que $S'\in
    \mathcal{C}$ y $\mathcal{C}$ es una propiedad de consistencia.
    Luego, $\bot\notin S$ y $\neg \top \notin S$ puesto que $S\subseteq
    S'$.

  \item Supongamos que $\neg \neg F \in S$, entonces $\neg \neg F \in
    S'$ ya que $S\subseteq S'$.  Luego $S'\cup \{F\}\in \mathcal{C}$, ya
    que $S'\in \mathcal{C}$ y $\mathcal{C}$ es una propiedad de
    consistencia; además $S\cup \{F\}\subseteq S'\cup \{F\}$ puesto que
    $S\subseteq S'$.  Por lo tanto, por definición de $\mathcal{C^{+}}$,
    se tiene que $S\cup \{F\}\in \mathcal{C^{+}}$.

  \item Supongamos que $\alpha \in S$, entonces $\alpha \in S'$ ya que
    $S\subseteq S'$.  Luego $S'\cup \{\alpha_1,\alpha_2\} \in
    \mathcal{C}$, ya que $S'\in \mathcal{C}$ y $\mathcal{C}$ es una
    propiedad de consistencia.

  Por otro lado $S\cup \{\alpha_1, \alpha_2\}\subseteq S'\cup
  \{\alpha_1,\alpha_2\}$ ya que, $S\subseteq S'$.  Por lo tanto, por
  definición de $\mathcal{C^{+}}$, se tiene que $S\cup \{\alpha_1,
  \alpha_2\}\in \mathcal{C^{+}}$.  \item Supongamos que $\beta \in S$,
  entonces $\beta\in S'$ puesto que que $S\subseteq S'$.

  Luego, $S'\cup \{\beta_1\}\in \mathcal{C}$ o $S'\cup \{\beta_2\}\in
  \mathcal{C}$ por ser $\mathcal{C}$ una propiedad de consistencia;
  además $S\cup \{\beta_1\} \subseteq S'\cup \{\beta_1\}$ y $S\cup
  \{\beta_2\} \subseteq S'\cup \{\beta_2\}$ ya que $S\subseteq S'$. Por
  lo tanto, por definición de $\mathcal{C^{+}}$, se tiene que $S\cup
  \{\beta_1\}\in \mathcal{C^{+}}$ o $S\cup \{\beta_2\}\in
  \mathcal{C^{+}}$.
  \end{enumerate}
  \mbox{}
  \end{demostracion}

  A continuación formalizamos cada parte del teorema anterior.  La
  formali\-zación de la parte (a) es la siguiente:
\<close>

lemma cerrado_subset: "\<C> \<subseteq> \<C>⁺"
proof -
  { fix S
    assume "S \<in> \<C>"
    moreover
    have "S \<subseteq> S" by simp
    ultimately
    have "S \<in> \<C>⁺"
      by (unfold clausura_subconj_def, auto) }
  thus ?thesis by auto
qed

text \<open>
  El siguiente lema formaliza la parte (b).
\<close>

lemma cerrado_cerrado: "subconj_cerrada (\<C>⁺)"
proof -
 { fix S T
   assume "S \<in> \<C>⁺" and "T \<subseteq> S"
   obtain S1 where "S1 \<in> \<C>" and "S \<subseteq> S1" using `S \<in> \<C>⁺`
     by (unfold clausura_subconj_def, auto)
   have "T \<subseteq> S1" using `T \<subseteq> S` and `S \<subseteq> S1`  by simp
   hence "T \<in> \<C>⁺" using `S1 \<in> \<C>`
     by (unfold clausura_subconj_def, auto)}
 thus ?thesis by (unfold subconj_cerrada_def, auto)
qed

text \<open>
  Los siguientes lemas corresponden a la formalización de los 5 casos de
  la parte (c) del teorema anterior.
\<close>

lemma condiconsisP1:
  assumes "consistenceP \<C>" and "T \<in> \<C>" and "S \<subseteq> T"
  shows "(\<forall>P. \<not>(atom P \<in> S \<and> (\<not>.atom P) \<in> S))"
(*<*)
proof (rule allI)+
  fix P
  show "\<not>(atom P  \<in> S \<and> (\<not>.atom P) \<in> S)"
  proof -
    have "\<not>(atom P \<in> T \<and> (\<not>.atom P) \<in> T)"
      using `consistenceP \<C>` and `T \<in> \<C>`
      by(simp add: consistenceP_def)
    thus "\<not>(atom P \<in> S \<and> (\<not>.atom P) \<in> S)" using `S \<subseteq> T` by auto
  qed
qed
(*>*)
text\<open> \<close>
lemma condiconsisP2:
  assumes "consistenceP \<C>" and "T \<in> \<C>" and "S \<subseteq> T"
  shows "FF \<notin> S \<and> (\<not>.TT)\<notin> S"
(*<*)
proof -
  have "FF \<notin> T \<and> (\<not>.TT)\<notin> T"
    using `consistenceP \<C>` and `T \<in> \<C>`
    by(simp add: consistenceP_def)
  thus "FF \<notin> S \<and> (\<not>.TT)\<notin> S" using `S \<subseteq> T` by auto
qed
(*>*)
text\<open> \<close>
lemma condiconsisP3:
  assumes "consistenceP \<C>" and "T \<in> \<C>" and "S \<subseteq> T"
  shows "\<forall>F. (\<not>.\<not>.F) \<in> S \<longrightarrow> S \<union> {F} \<in> \<C>⁺"
proof(rule allI)
(*<*)
  fix F
  show "(\<not>.\<not>.F) \<in> S \<longrightarrow>  S \<union> {F} \<in> \<C>⁺"
  proof (rule impI)
    assume "(\<not>.\<not>.F) \<in> S"
    hence "(\<not>.\<not>.F) \<in> T" using `S \<subseteq> T` by auto
    hence "T \<union> {F} \<in> \<C>" using `consistenceP \<C>` and `T \<in> \<C>`
      by(simp add: consistenceP_def)
    moreover
    have "S \<union> {F} \<subseteq>  T \<union> {F}" using `S \<subseteq> T` by auto
    ultimately
    show "S \<union> {F} \<in> \<C>⁺"
      by (auto simp add: clausura_subconj_def)
  qed
qed
(*>*)
text\<open> \<close>
lemma condiconsisP4:
  assumes "consistenceP \<C>" and "T \<in> \<C>" and "S \<subseteq> T"
  shows "\<forall>F. ((FormulaAlfa F) \<and> F \<in> S) \<longrightarrow> (S \<union> {Comp1 F, Comp2 F}) \<in> \<C>⁺"
(*<*)
proof (rule allI)
  fix F
  show "((FormulaAlfa F) \<and> F \<in> S) \<longrightarrow> S \<union> {Comp1 F, Comp2 F} \<in> \<C>⁺"
  proof (rule impI)
    assume "((FormulaAlfa F) \<and> F \<in> S)"
    hence "FormulaAlfa F" and  "F \<in> T" using `S \<subseteq> T` by auto
    hence  "T \<union> {Comp1 F, Comp2 F} \<in> \<C>"
      using `consistenceP \<C>` and `FormulaAlfa F` and `T \<in> \<C>`
      by (auto simp add: consistenceP_def)
    moreover
    have "S \<union> {Comp1 F, Comp2 F} \<subseteq> T \<union> {Comp1 F, Comp2 F}"
      using `S \<subseteq> T` by auto
    ultimately
    show  "S \<union> {Comp1 F, Comp2 F} \<in> \<C>⁺"
      by (auto simp add: clausura_subconj_def)
  qed
qed
(*>*)
text\<open> \<close>
lemma condiconsisP5:
  assumes "consistenceP \<C>" and "T \<in> \<C>" and "S \<subseteq> T"
  shows "(\<forall>F. ((FormulaBeta F) \<and> F \<in> S) \<longrightarrow>
              (S \<union> {Comp1 F} \<in> \<C>⁺) \<or> (S \<union> {Comp2 F} \<in> \<C>⁺))"
(*<*)
proof (rule allI)
  fix F
  show "((FormulaBeta F) \<and> F \<in> S) \<longrightarrow> S \<union> {Comp1 F} \<in> \<C>⁺ \<or> S \<union> {Comp2 F} \<in> \<C>⁺"
  proof (rule impI)
    assume "(FormulaBeta F) \<and> F \<in> S"
    hence "FormulaBeta F" and "F \<in> T" using `S \<subseteq> T` by auto
    hence "T \<union> {Comp1 F} \<in> \<C> \<or> T \<union> {Comp2 F} \<in> \<C>"
      using `consistenceP \<C>` and `FormulaBeta F` and `T \<in> \<C>`
      by(simp add: consistenceP_def)
    moreover
    have "S \<union> {Comp1 F} \<subseteq> T \<union> {Comp1 F}" and "S \<union> {Comp2 F} \<subseteq> T \<union> {Comp2 F}"
      using `S \<subseteq> T` by auto
    ultimately
    show "S \<union> {Comp1 F} \<in> \<C>⁺ \<or> S \<union> {Comp2 F} \<in> \<C>⁺"
      by(auto simp add: clausura_subconj_def)
  qed
qed
(*>*)
text \<open>
  Por último, la formalización de la parte (c) del teorema
  \ref{CerraduraSubconjuntosP} es la siguiente:
\<close>

theorem cerrado_consistenceP:
  assumes hip1: "consistenceP \<C>"
  shows "consistenceP (\<C>⁺)"
proof -
  { fix S
    assume "S \<in> \<C>⁺"
    hence "\<exists>T\<in>\<C>. S \<subseteq> T" by(simp add: clausura_subconj_def)
    then obtain T where hip2: "T \<in> \<C>" and hip3: "S \<subseteq> T" by auto
    have "(\<forall>P. \<not> (atom P \<in> S \<and> (\<not>.atom P) \<in> S)) \<and>
               FF \<notin> S \<and> (\<not>.TT) \<notin> S \<and>
               (\<forall>F. (\<not>.\<not>.F) \<in> S \<longrightarrow> S \<union> {F} \<in> \<C>⁺) \<and>
               (\<forall>F. ((FormulaAlfa F) \<and> F \<in> S) \<longrightarrow>
                    (S \<union> {Comp1 F, Comp2 F}) \<in> \<C>⁺) \<and>
               (\<forall>F. ((FormulaBeta F) \<and> F \<in> S) \<longrightarrow>
                    (S \<union> {Comp1 F} \<in> \<C>⁺) \<or> (S \<union> {Comp2 F} \<in> \<C>⁺))"
      using
        condiconsisP1[OF hip1 hip2 hip3]  condiconsisP2[OF hip1 hip2 hip3]
        condiconsisP3[OF hip1 hip2 hip3]  condiconsisP4[OF hip1 hip2 hip3]
        condiconsisP5[OF hip1 hip2 hip3]
      by blast}
  thus ?thesis by (simp add: consistenceP_def)
qed

(*<*)
end
(*>*)


(*
 * Copyright 2019, Data61
 * Commonwealth Scientific and Industrial Research Organisation (CSIRO)
 * ABN 41 687 119 230.
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(DATA61_BSD)
 *)

theory FP_Eval
imports
  HOL.HOL
  "ml-helpers/TermPatternAntiquote"
begin

text \<open>
  FP_Eval: efficient evaluator for functional programs.

  The algorithm is similar to @{method simp}, but streamlined somewhat.
  Poorly-scaling simplifier features are omitted, e.g.:
  conditional rules, eta normalisation, rewriting under lambdas, etc.

  See FP_Eval_Tests for examples and tests. Currently, only
  ML conversions and tactics are provided.

  Features:
    \<bullet> Low overhead (usually lower than @{method simp})
    \<bullet> Applicative-order evaluation to WHNF (doesn't rewrite under lambdas)
    \<bullet> Manual specification of rewrite rules, no global context
    \<bullet> Cong rules supported for controlling evaluation (if, let, case, etc.)
    \<bullet> Finer control than simp: explicit skeletons, debugging callbacks,
       perf counters (see signature for FP_Eval.eval')

  Major TODOs:
    \<bullet> Preprocess rewrite rules for speed
    \<bullet> Optimize eval_rec more
    \<bullet> Support for simprocs (ideally with static checks)
    \<bullet> Simple tactical and Isar method wrappers
    \<bullet> Automatic ruleset builders
    \<bullet> Static analysis for rules:
      \<bullet> Confluence, termination
      \<bullet> Completeness
      \<bullet> Running time?
    \<bullet> Dynamic analysis e.g. unused rules

  Work in progress.
\<close>

locale FP_Eval begin
lemma bool_prop_eq_True:
  "Trueprop P \<equiv> (P \<equiv> True)"
  by (simp add: atomize_eq)

lemma bool_prop_eq_False:
  "Trueprop (\<not>P) \<equiv> (P \<equiv> False)"
  by (simp add: atomize_eq)
end

ML \<open>
structure FP_Eval = struct

(*** Utils ***)

(* O(1) version of thm RS @{thm eq_reflection} *)
fun then_eq_reflection thm = let
  val (x, y) = Thm.dest_binop (Thm.dest_arg (Thm.cprop_of thm));
  val cT = Thm.ctyp_of_cterm x;
  val rule = @{thm eq_reflection} |> Thm.instantiate' [SOME cT] [SOME x, SOME y];
  in Thm.implies_elim rule thm end;

fun bool_conv_True thm =
      Thm.instantiate ([], [((("P", 0), @{typ bool}),
                             Thm.dest_arg (Thm.cprop_of thm))])
                      @{thm FP_Eval.bool_prop_eq_True}
      |> (fn conv => Thm.equal_elim conv thm);

fun bool_conv_False thm =
      Thm.instantiate ([], [((("P", 0), @{typ bool}),
                             Thm.dest_arg (Thm.dest_arg (Thm.cprop_of thm)))])
                      @{thm FP_Eval.bool_prop_eq_False}
      |> (fn conv => Thm.equal_elim conv thm);

(* Emulate simp's conversion of non-equational rules to "P \<equiv> True", etc. *)
fun maybe_convert_eqn thm =
      (* HACK: special case to transform @{thm refl} to "(HOL.eq ?t ?t) \<equiv> True",
               as the default result of "?t \<equiv> ?t" isn't what we want *)
      if Thm.eq_thm_prop (thm, @{thm refl}) then SOME (bool_conv_True thm) else
      (case Thm.prop_of thm of
           @{term_pat "Trueprop (_ = _)"} =>
             SOME (then_eq_reflection thm)
         | @{term_pat "Trueprop (\<not> _)"} =>
             SOME (bool_conv_False thm)
         | @{term_pat "_ \<equiv> _"} => SOME thm
         | @{term_pat "Trueprop _"} =>
             SOME (bool_conv_True thm)
         | _ => NONE);

(* FIXME: turn into Config.
   NB: low-level eval' ignores this global setting *)
(* 0: none; 1: summary details; 2+: everything *)
val trace = Unsynchronized.ref 0;

(*** Data structures ***)

(* TODOs:
     - cond rules?
     - simprocs?
     - skeleton optimisation?
*)
type eqns_for_const =
  int * (* arity of const (we require it to be equal in all rules) *)
  (int list * thm) option * (* possible cong rule skeleton (list of which args to evaluate) *)
  thm Net.net; (* eval equations *)
(* NB: the cong thm is never actually used; it only tells
       fp_eval how to perform the rewriting. *)

(* Main fp_eval context *)
type rules = eqns_for_const Symtab.table;

(* For completeness, though make_rules is preferred *)
val empty_rules : rules = Symtab.empty;

(*** Data structure operations ***)

(* Must be simple Pure.eq equations *)
val net_from_eqns : thm list -> thm Net.net = fn eqns =>
      let fun lift_eqn eqn = (case Thm.prop_of eqn of
                                  @{term_pat "_ \<equiv> _"} => eqn
                                | _ => raise THM ("net_from_eqns: not a simple equation", 0, [eqn]));
           val eqns' = map lift_eqn eqns;
           fun insert eqn = Net.insert_term (K false) (Thm.term_of (Thm.lhs_of eqn), eqn);
      in fold_rev insert eqns' Net.empty end;

(* Must be a simple Pure.eq equation, or convertible to one *)
fun add_eqn raw_eqn : rules -> rules =
  let val eqn = case maybe_convert_eqn raw_eqn of
                    NONE => raise THM ("add_eqn: can't use this as equation", 0, [raw_eqn])
                  | SOME eqn => eqn;
      val eqn_lhs = Thm.term_of (Thm.lhs_of eqn);
      val (cname, args) = case strip_comb eqn_lhs of
                            (* This should be OK because Const names are qualified *)
                              (Const (cname, _), args) => (cname, args)
                            | (Free (cname, _), args) => (cname, args)
                            | _ => raise THM ("add_eqn: head of LHS is not a constant", 0, [eqn]);
      val arity = length args;
      val empty_entry = (cname, (arity, NONE, Net.empty));
      fun update_entry (arity', cong, net) =
            if arity <> arity'
            then raise THM ("add_eqn: arity mismatch for " ^ cname ^
                            " (existing=" ^ string_of_int arity' ^
                            ", new=" ^ string_of_int arity ^ ")", 0, [raw_eqn])
            else (arity, cong, Net.insert_term (K false) (eqn_lhs, eqn) net);
  in Symtab.map_default empty_entry update_entry end

(* Helper for add_cong. cong_thm must be a weak cong rule of the form

    "\<lbrakk> ?x_i = ?y_i;
       ?x_j = ?y_j \<rbrakk> \<Longrightarrow>
     my_const ?x_1 ?x_2 ... ?x_i ... = my_const ?x_1 ... ?y_i ..."

   Returns indices of ?x_i in the LHS of the conclusion.
 *)
fun process_cong cong_thm : string * int * int list =
  let fun die msg terms = raise TERM ("add_cong: " ^ msg, terms @ [Thm.prop_of cong_thm]);
      (* LHS vars in premises tell us which order to use for rewriting *)
      fun dest_prem (Const (@{const_name Pure.eq}, _) $ Var (vl, _) $ Var (vr, _)) = (vl, vr)
        | dest_prem (@{const Trueprop} $
                        (Const (@{const_name HOL.eq}, _) $ Var (vl, _) $ Var (vr, _))) = (vl, vr)
        | dest_prem t = die "premise not a simple equality" [t];
      val prem_pairs = Logic.strip_imp_prems (Thm.prop_of cong_thm)
                       |> map dest_prem;
      (* check concl and get LHS argument list *)
      val (concl_lhs, concl_rhs) =
        case Logic.strip_imp_concl (Thm.prop_of cong_thm) of
            @{term_pat "?lhs \<equiv> ?rhs"} => (lhs, rhs)
          | @{term_pat "Trueprop (?lhs = ?rhs)"} => (lhs, rhs)
          | concl => die "concl not a simple equality" [concl];
      val (cname, arg_pairs) = case apply2 strip_comb (concl_lhs, concl_rhs) of
              ((head as Const (cname, _), args1), (head' as Const (cname', _), args2)) =>
                if cname <> cname'
                  then die "different consts" [head, head']
                else if length args1 <> length args2
                  then die "different arities" [concl_lhs, concl_rhs]
                else if not (forall is_Var (args1 @ args2))
                  then die "args not schematic vars" [concl_lhs, concl_rhs]
                else (cname, map (apply2 (dest_Var #> fst)) (args1 ~~ args2))
            | _ => die "equation heads are not constants" [concl_lhs, concl_rhs];
      (* for each prem LHS, find its argument position in the concl *)
      fun prem_index var = case find_index (fn v => v = var) (map fst arg_pairs) of
                              ~1 => die "var in prems but not conclusion" [Var (var, dummyT)]
                            | n => n;
      val prem_indices = map prem_index (map fst prem_pairs);
      (* ensure no duplicates, otherwise fp_eval would do multiple evaluations *)
      val _ = case duplicates (op=) prem_indices of
                  [] => ()
                | (n::_) => die "var appears twice in prems" [Var (fst (nth prem_pairs n), dummyT)];
      (* TODO: we could do even more checking here, but most other errors would
               cause fp_eval to fail-fast *)
      val const_arity = length arg_pairs;
  in (cname, const_arity, prem_indices) end;

fun add_cong cong_thm : rules -> rules =
  let val (cname, arity, cong_spec) = process_cong cong_thm;
      val empty_entry = (cname, (arity, NONE, Net.empty));
      fun update_entry (arity', opt_cong, net) =
            if arity <> arity'
            then raise THM ("add_cong: arity mismatch for " ^ cname ^
                            " (existing=" ^ string_of_int arity' ^
                            ", new=" ^ string_of_int arity ^ ")", 0, [cong_thm])
            else case opt_cong of
                      NONE => (arity, SOME (cong_spec, cong_thm), net)
                    | SOME (cong_spec', cong_thm') =>
                        if cong_spec = cong_spec'
                        then (warning ("add_cong: adding duplicate for " ^ cname);
                              (arity, opt_cong, net))
                        else raise THM ("add_cong: different cong rule already exists for " ^ cname,
                                        0, [cong_thm', cong_thm]);
  in Symtab.map_default empty_entry update_entry end;

(* Simple builder *)
fun make_rules eqns congs = fold_rev add_eqn eqns (fold add_cong congs empty_rules);

fun merge_rules (r1, r2) =
  let fun merge_const cname (r as (arity, cong, net), r' as (arity', cong', net')) =
        if pointer_eq (r, r') then r else
        let val _ = if arity = arity' then () else
                      error ("merge_rules: different arity for " ^ cname ^ ": " ^
                             string_of_int arity ^ ", " ^ string_of_int arity');
            val cong'' = case (cong, cong') of
                            (NONE, NONE) => NONE
                          | (SOME _, NONE) => cong
                          | (NONE, SOME _) => cong'
                          | (SOME (_, thm), SOME (_, thm')) =>
                              if Thm.eq_thm_prop (thm, thm') then cong else
                                raise THM ("merge_rules: different cong rules for " ^ cname, 0,
                                           [thm, thm']);
        in (arity, cong'', Net.merge Thm.eq_thm_prop (net, net')) end;
  in if pointer_eq (r1, r2) then r1 else
       Symtab.join merge_const (r1, r2)
  end;

fun dest_rules rules =
      let val const_rules = Symtab.dest rules |> map snd;
          val eqnss = map (fn (_, _, net) => Net.content net) const_rules;
          val congs = map_filter (fn (_, cong, _) => Option.map snd cong) const_rules;
      in (List.concat eqnss, congs) end;

(*** Evaluator ***)

(* Skeleton terms track which subterms have already been fully
   evaluated and can be skipped. This follows the same method as
   Raw_Simplifier.bottomc. *)
val skel0 = Bound 0; (* always descend and rewrite *)
val skel_skip = Var (("", 0), dummyT); (* always skip *)

(* Full interface *)
fun eval' (ctxt: Proof.context)
          (debug_trace: int -> (unit -> string) -> unit) (* debug callback: level, message *)
          (breakpoint: cterm -> bool) (* if true, stop rewriting and return *)
          (eval_under_var: bool) (* if true, expand partially applied funcs under Var skeletons *)
          (rules: rules)
          (ct0: cterm, ct0_skel: term)
          (* eqn, final skeleton, perf counters *)
          : (thm * term) * (string * int) list = let
      (* Performance counters *)
      val counter_eval_rec    = Unsynchronized.ref 0;
      val counter_try_rewr    = Unsynchronized.ref 0;
      val counter_rewrite1    = Unsynchronized.ref 0;
      val counter_rewrites    = Unsynchronized.ref 0;
      val counter_rewr_skel   = Unsynchronized.ref 0;
      val counter_beta_redc   = Unsynchronized.ref 0;
      val counter_transitive  = Unsynchronized.ref 0;
      val counter_combination = Unsynchronized.ref 0;
      val counter_dest_comb   = Unsynchronized.ref 0;
      val counter_congs       = Unsynchronized.ref 0;
      fun increment c = (c := !c + 1);

      (* Debug output *)
      val print_term = Syntax.string_of_term ctxt;
      val print_cterm = print_term o Thm.term_of;
      fun print_maybe_thm t = Option.getOpt (Option.map (print_term o Thm.prop_of) t, "<none>");

      (* Utils *)
      fun my_transitive t1 t2 =
            (increment counter_transitive;
             Thm.transitive t1 t2);
      fun my_combination t1 t2 =
            (increment counter_combination;
             Thm.combination t1 t2);

      fun transitive1 NONE NONE = NONE
        | transitive1 (t1 as SOME _) NONE = t1
        | transitive1 NONE (t2 as SOME _) = t2
        | transitive1 (SOME t1) (SOME t2) = SOME (my_transitive t1 t2);

      fun maybe_rewr_result NONE ct = ct
        | maybe_rewr_result (SOME rewr) _ = Thm.rhs_of rewr;

      fun maybe_eqn (SOME eqn) _ = eqn
        | maybe_eqn _ ct = Thm.reflexive ct;

      fun combination1 _ NONE _ NONE = NONE
        | combination1 cf cf_rewr cx cx_rewr =
            SOME (my_combination (maybe_eqn cf_rewr cf) (maybe_eqn cx_rewr cx));

      (* strip_comb; invent skeleton to same depth if required *)
      val strip_comb_skel = let
            fun strip (f $ x, fK $ xK, ts) = strip (f, fK, (x, xK)::ts)
              | strip (f $ x, skel as Var _, ts) =
                  (* if a sub-comb is normalized, expand it for matching purposes,
                     but don't expand children *)
                  if eval_under_var then strip (f, skel, (x, skel)::ts)
                  else (f $ x, skel, ts)
              (* skeleton doesn't match; be conservative and expand all *)
              | strip (f $ x, _, ts) = strip (f, skel0, (x, skel0)::ts)
              | strip (f, fK, ts) = (f, fK, ts) (* finish *);
            in fn (t, skel) => strip (t, skel, []) end;

      (* strip_comb for cterms *)
      val strip_ccomb : cterm -> int -> cterm * cterm list = let
            fun strip ts t n = if n = 0 then (t, ts) else
                  case Thm.term_of t of
                      _ $ _ => let val (f, x) = Thm.dest_comb t;
                                   (* yes, even dest_comb is nontrivial *)
                                   val _ = increment counter_dest_comb;
                               in strip (x::ts) f (n-1) end
                    | _ => (t, ts);
            in strip [] end;

      (* find the first matching eqn and use it *)
      fun rewrite1 _  [] = NONE
        | rewrite1 ct (eqn::eqns) = let
            val _ = increment counter_rewrite1;
            in
              SOME (Thm.instantiate (Thm.first_order_match (Thm.lhs_of eqn, ct)) eqn, eqn)
              |> tap (fn _ => increment counter_rewrites)
              handle Pattern.MATCH => rewrite1 ct eqns
            end;

      (* Apply rewrite step to skeleton.
         FIXME: traverses whole RHS. If the RHS is large and the rest of the
                evaluation ignores most of it, then this is wasted work.
                Either preprocess eqn or somehow update skel lazily *)
      fun rewrite_skel eqn skel =
        let val _ = debug_trace 2 (fn () => "rewrite_skel: " ^ print_maybe_thm (SOME eqn) ^ " on " ^ print_term skel);
            (* FIXME: may be wrong wrt. first_order_match--eta conversions? *)
            fun match (Var (v, _)) t = Vartab.map_default (v, t) I
              | match (pf $ px) (f $ x) = match pf f #> match px x
              | match (pf $ px) (t as Var _) = match pf t #> match px t
              | match (Abs (_, _, pt)) (Abs (_, _, t)) = match pt t
              | match (Abs (_, _, pt)) (t as Var _) = match pt t
              | match _ _ = I;
            val inst = match (Thm.term_of (Thm.lhs_of eqn)) skel Vartab.empty;
            fun subst (t as Var (v, _)) = Option.getOpt (Vartab.lookup inst v, t)
              | subst t = t;
            (* Consts in the RHS that don't appear in our rewrite rules, are also normalised *)
            fun norm_consts (t as Var _) = t
              | norm_consts (t as Bound _) = t
              | norm_consts (Abs (v, T, t)) = Abs (v, T, norm_consts t)
              | norm_consts (t as Const (cname, _)) =
                  if Symtab.defined rules cname then t else Var ((cname, 0), dummyT)
              | norm_consts (t as Free (cname, _)) =
                  if Symtab.defined rules cname then t else Var ((cname, 0), dummyT)
              | norm_consts (f $ x) =
                  let val f' = norm_consts f;
                      val x' = norm_consts x;
                  in case (f', x') of
                          (Var _, Var _) => f'
                        | _ => f' $ x'
                  end;
        in map_aterms subst (Thm.term_of (Thm.rhs_of eqn))
           |> tap (fn t' => counter_rewr_skel := !counter_rewr_skel + size_of_term t')
           |> norm_consts
           |> tap (fn t' => debug_trace 2 (fn () => "rewrite_skel:   ==> " ^ print_term t')) end;

      fun apply_skel (f as Var _) (Var _) = f
        | apply_skel (f as Abs _) x = betapply (f, x)
        | apply_skel f x = f $ x;

      (* Main structure.
         We just rewrite all combinations inside-out, and ignore everything else.
         Special cases:
          - Combinations may have no arguments; this expands a single Const or Free.
          - A combination may have more args than the arity of its head, e.g.
            "If c t f x y z ...". In this case, we rewrite "If c t f" only,
            then recurse on the new combination.
          - If the head is a lambda abs, its arity is considered to be the number of
            bound vars; they are evaluated first and then beta redc is performed.
       *)
      val reached_breakpoint = Unsynchronized.ref false;
      fun eval_rec (ct, skel) =
        ((if !reached_breakpoint then () else reached_breakpoint := breakpoint ct);
         if !reached_breakpoint
         then (debug_trace 1 (fn () => "eval_rec: triggered breakpoint on: " ^ print_cterm ct);
               (NONE, skel))
         else
          (increment counter_eval_rec;
           debug_trace 2 (fn () => "eval_rec: " ^ print_cterm ct ^ " (skel: " ^ print_term skel ^ ")");
            case skel of
                Var _ => (NONE, skel)
              | Abs _ => (NONE, skel)
              | _ => let
                val (head, head_skel, args) = strip_comb_skel (Thm.term_of ct, skel);
                val (chead, cargs) = strip_ccomb ct (length args);
                (* rules for head, if any *)
                val maybe_head_rules =
                      case head of
                          Const (cname, _) => Symtab.lookup rules cname
                        | Free (cname, _) => Symtab.lookup rules cname
                        | _ => NONE;

                val beta_depth = let
                      fun f (Abs (_, _, t)) = 1 + f t
                        | f _ = 0;
                      in Int.min (length args, f head) end;

                (* Emulating call by value. First, we find the equation arity of the head.
                   We evaluate a number of args up to the arity, except if the head has a
                   cong specification, we follow the cong spec. *)
                val (eval_args, effective_arity) =
                      case maybe_head_rules of
                          SOME (arity, maybe_cong, _) =>
                            if length args < arity
                            then (List.tabulate (length args, I), length args)
                            else (case maybe_cong of
                                      NONE => (List.tabulate (arity, I), arity)
                                    | SOME (indices, cong_thm) =>
                                        (increment counter_congs;
                                         debug_trace 2 (fn () => "eval_rec:   will use cong skeleton: " ^ print_maybe_thm (SOME cong_thm));
                                         (indices, arity)))
                          (* If head has no equations, just evaluate all arguments. *)
                        | NONE => let val d = if beta_depth = 0 then length args else beta_depth;
                                  in (List.tabulate (d, I), d) end;
                val skip_args = subtract op= eval_args (List.tabulate (length args, I));

                (* evaluate args *)
                fun eval_arg i = (i, (nth cargs i, eval_rec (nth cargs i, snd (nth args i))));
                fun skip_arg i = (i, (nth cargs i, (NONE, snd (nth args i))));
                val arg_convs = map eval_arg eval_args @ map skip_arg skip_args
                                |> sort (int_ord o apply2 fst) |> map snd;

                (* substitute results up to arity of head *)
                (* TODO: avoid unnecessary cterm ops? *)
                fun recombine beta_redc =
                      fold (fn (arg, (arg_conv, arg_skel)) => fn (f, (f_conv, f_skel)) =>
                              let val comb_thm = combination1 f f_conv arg arg_conv;
                                  val result = maybe_rewr_result comb_thm (Thm.apply f arg);
                              (* respect breakpoint, if set *)
                              in case (if not beta_redc orelse !reached_breakpoint then Bound 0
                                       else Thm.term_of f) of
                                      Abs _ => let
                                        val _ = debug_trace 2 (fn () =>
                                                  "eval_rec:   beta redc: " ^ print_cterm result);
                                        val _ = increment counter_beta_redc;
                                        val beta_thm = Thm.beta_conversion false result;
                                        (* f_skel must be Abs, for apply_skel to do what we want *)
                                        val f_skel' = case f_skel of Abs _ => f_skel
                                                                   | _ => Thm.term_of f;
                                        in (Thm.rhs_of beta_thm,
                                            (transitive1 comb_thm (SOME beta_thm),
                                             apply_skel f_skel' arg_skel)) end
                                    | _ => (result, (comb_thm, apply_skel f_skel arg_skel))
                              end);

                val (ct', (arg_conv, skel')) =
                       recombine true
                           (take effective_arity arg_convs)
                           (chead, (NONE, head_skel));

                (* Now rewrite the application of head to args *)
                val _ = debug_trace 2 (fn () => "eval_rec:   head is " ^ print_term head ^
                                                ", (effective) arity " ^ string_of_int effective_arity);
                in case maybe_head_rules of (* TODO: refactor the following *)
                      NONE =>
                        if beta_depth = 0
                        then let (* No equation and not Abs head, so mark as normalised.
                                    We also know effective_arity = length args, so arg_convs
                                    is complete *)
                                 val _ = @{assert} (effective_arity = length args);
                                 val skel'' = case head of Abs _ => skel' | _ =>
                                                fold (fn x => fn f => apply_skel f x)
                                                     (map (snd o snd) arg_convs) skel_skip;
                                 in (arg_conv, skel'') end
                        else let (* Add remaining args and continue rewriting *)
                                 val (ct'', (conv'', skel'')) =
                                       recombine false
                                           (drop effective_arity arg_convs)
                                           (maybe_rewr_result arg_conv ct', (arg_conv, skel'));
                                 val (final_conv, final_skel) = eval_rec (ct'', skel'');
                             in (transitive1 conv'' final_conv, final_skel) end
                    | SOME (arity, _, net) =>
                        if effective_arity < arity then (arg_conv, skel') else
                        let val rewr_result =
                              if !reached_breakpoint then NONE else
                                (debug_trace 2 (fn () => "eval_rec:   now rewrite head from: " ^ print_cterm ct');
                                 rewrite1 ct' (Net.match_term net (Thm.term_of ct')));
                        in case rewr_result of
                              NONE =>
                                (* No equations; add remaining args and mark head as normalised *)
                                let val (_, (conv'', _)) =
                                          recombine false
                                              (drop effective_arity arg_convs)
                                              (ct', (arg_conv, skel'));
                                    val skel'' = fold (fn x => fn f => apply_skel f x)
                                                      (map (snd o snd) arg_convs) skel_skip;
                                in (conv'', skel'') end
                            | SOME (conv, rule) =>
                                let val _ = debug_trace 2 (fn () => "eval: "
                                              ^ print_maybe_thm (SOME conv) ^ "\n  using: "
                                              ^ print_maybe_thm (SOME rule));
                                    val _ = increment counter_try_rewr;
                                    val rhs_skel = rewrite_skel rule skel';
                                    val conv' = case arg_conv of NONE => conv
                                                               | SOME t => my_transitive t conv;
                                    val _ = debug_trace 2 (fn () =>
                                                "eval_rec:   after rewrite: " ^ print_maybe_thm (SOME conv'));
                                    (* Add remaining args and continue rewriting *)
                                    val (ct'', (conv'', skel'')) =
                                          recombine false
                                              (drop effective_arity arg_convs)
                                              (Thm.rhs_of conv', (SOME conv', rhs_skel));
                                    val (final_conv, final_skel) = eval_rec (ct'', skel'');
                                in (transitive1 conv'' final_conv, final_skel) end
                        end
                end
                |> tap (fn (conv, skel) => debug_trace 2 (fn () =>
                         "result: " ^ print_maybe_thm (SOME (maybe_eqn conv ct)) ^ "\n  skel: " ^ print_term skel))
          ));

      (* Final result *)
      val (ct_rewr, final_skel) = eval_rec (ct0, ct0_skel);
      val counters = [
            ("eval_rec",    !counter_eval_rec),
            ("try_rewr",    !counter_try_rewr),
            ("rewrite1",    !counter_rewrite1),
            ("rewrites",    !counter_rewrites),
            ("rewr_skel",   !counter_rewr_skel),
            ("beta_redc",   !counter_beta_redc),
            ("transitive",  !counter_transitive),
            ("combination", !counter_combination),
            ("dest_comb",   !counter_dest_comb),
            ("congs",       !counter_congs)
            ];
  in ((maybe_eqn ct_rewr ct0, final_skel), counters) end;

(* Simplified interface with common defaults *)
fun eval (ctxt: Proof.context)
         (rules: rules)
         : (cterm * term) -> ((thm * term) * (string * int) list) =
  let fun debug_trace level msg = if level <= !trace then tracing (msg ()) else ();
      fun breakpoint _ = false;
      val eval_under_var = false;
  in eval' ctxt debug_trace breakpoint eval_under_var rules end;

(* Even simpler interface; uses default skel *)
fun eval_conv ctxt rules: conv =
  rpair skel0 #> eval ctxt rules #> fst #> fst;

(* FIXME: eval doesn't rewrite under binders, we should add some forall_conv here *)
fun eval_tac ctxt rules n: tactic =
  Conv.gconv_rule (eval_conv ctxt rules) n
  #> Seq.succeed;

end;
\<close>

text \<open>See FP_Eval_Tests for explanation\<close>
lemma (in FP_Eval) let_weak_cong':
  "a = b \<Longrightarrow> Let a t = Let b t"
  by simp

end


(*<*)
theory Resumen
imports Main "HOL-Library.LaTeXsugar" "HOL-Library.OptionalSugar"
begin
(*>*)

text \<open>
El objetivo de la Lógica es la formalización del conocimiento y su
razonamiento. En este trabajo, estudiaremos elementos de la lógica
proposicional desde la perspectiva teórica de \<open>First−Order Logic and
Automated Theorem Proving\<close> \<open>[4]\<close> de Melvin Fitting. En particular, nos
centraremos en la sintaxis y la semántica, concluyendo con la versión
proposicional del lema de Hintikka sobre la satisfacibilidad de una
clase determinada de conjuntos de fórmulas. Siguiendo la inspiración de
\<open>Propositional Proof Systems\<close> \<open>[10]\<close> por Julius Michaelis y Tobias
Nipkow, los resultados expuestos serán formalizados mediante Isabelle:
un demostrador interactivo que incluye herramientas de razonamiento
automático para guiar al usuario en el proceso de formalización,
verificación y automatización de resultados. Concretamente, Isabelle/HOL
es una especialización de Isabelle para la lógica de orden superior.
Las demostraciones de los resultados en Isabelle/HOL se elaborarán
siguiendo dos tácticas distintas a lo largo del trabajo. En primer
lugar, cada lema será probado de manera detallada prescindiendo de toda
herramienta de razonamiento automático, como resultado de una búsqueda
inversa en cada paso de la prueba. En contraposición, elaboraremos una
demostración automática alternativa de cada resultado que utilice todas
las herramientas de razonamiento automático que proporciona el
demostrador. De este modo, se evidenciará la capacidad de razonamiento
automático de Isabelle.
   \<close>

(*section \<open>Abstract \<close>*)

text\<open>Logic’s purpose is about knowledge’s formalisation and its
reasoning. In this project, we will approach Propositional Logic’s
elements from the theoretical perspective of \<open>First−Order Logic and
Automated Theorem Proving\<close> \<open>[4]\<close> by Melvin Fitting. We will focus on the
study of Syntax and Semantics to reach propositional version of
Hintikka’s lemma, which determinate the satisfiability of a concrete
type of formula set. Inspired by \<open>Propositional Proof Systems\<close> \<open>[10]\<close> by
Julius Michaelis and Tobias Nipkow, these results will be formalised
using Isabelle: a proof assistant including automatic reasoning tools
to guide the user on formalising, verifying and automating results. In
particular, Isabelle/HOL is the specialization of Isabelle for
High-Order Logic. The processing of the results formalised in
Isabelle/HOL follows two directions. In the first place, each lemma
will be proved on detail without any automation, as the result of an
inverse research on every step of the demonstration until it is only
completed with deductions based on elementary rules and definitions.
Conversely, we will alternatively prove the results using all the
automatic reasoning tools that are provide by the proof assistant. In
this way,\\ Isabelle’s power of automatic reasoning will be shown as the
contrast between these two different proving tactics.
\<close>

(*<*)
end
(*>*)


section \<open>Implementation of Flow Networks\<close>
theory Network_Impl
imports
  "Lib/Refine_Add_Fofu"
  Ford_Fulkerson
begin

subsection \<open>Type Constraints\<close>
text \<open>We constrain the types that we use for implementation.\<close>

text \<open>We define capacities to be integer values.\<close>
type_synonym capacity_impl = int
type_synonym flow_impl = "capacity_impl flow"

text \<open>We define a locale that assumes that the nodes are natural numbers in the
  range @{term "{0..<N}"}.\<close>

locale Network_Impl = Network c s t for c :: "capacity_impl graph" and s t +
  fixes N :: nat
  assumes V_ss: "V\<subseteq>{0..<N}"
begin
  lemma E_ss: "E \<subseteq> {0..<N}\<times>{0..<N}" using E_ss_VxV V_ss by auto
end \<comment> \<open>Network Implementation Locale\<close>

subsection \<open>Basic Operations\<close>

context Network_Impl
begin
  subsubsection \<open>Residual Graph\<close>
  text \<open>Get the residual capacity of an edge.\<close>
  definition cf_get :: "flow_impl \<Rightarrow> edge \<Rightarrow> capacity_impl nres"
    where "cf_get cf e \<equiv> do {
      assert (e\<in>E \<union> E\<inverse>);
      return (cf e)
    }"

  text \<open>Update the residual capacity of an edge.\<close>
  definition cf_set :: "flow_impl \<Rightarrow> edge \<Rightarrow> capacity_impl \<Rightarrow> flow_impl nres"
    where "cf_set cf e x \<equiv> do {
      assert (e\<in>E \<union> E\<inverse>);
      return (cf (e:=x))
    }"

  text \<open>Obtain the initial residual graph.\<close>
  definition cf_init :: "flow_impl nres"
    where "cf_init \<equiv> return (op_mtx_new c)"

  subsubsection \<open>Adjacency Map\<close>
  text \<open>Obtain the list of adjacent nodes for a specified node.\<close>
  definition am_get :: "(node \<Rightarrow> node list) \<Rightarrow> node \<Rightarrow> node list nres"
    where "am_get am u \<equiv> do {
      assert (u\<in>V);
      return (am u)
    }"

  text \<open>Test whether a node identifier is actually a node.
    As not all numbers in the range @{term \<open>{0..<N}\<close>} must identify nodes,
    this function uses the adjacency map to check whether there are adjacent
    edges. Due to the network constraints, all nodes have adjacent edges.
  \<close>
  definition am_is_in_V :: "(node \<Rightarrow> node list) \<Rightarrow> node \<Rightarrow> bool nres"
    where "am_is_in_V am u \<equiv> do {
      return (am u \<noteq> [])
    }"

  lemma am_is_in_V_correct[THEN order_trans, refine_vcg]:
    assumes "(am,adjacent_nodes) \<in> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>list_set_rel"
    shows "am_is_in_V am u \<le> (spec x. x \<longleftrightarrow> u\<in>V)"
  proof -
    have "u\<in>V \<longleftrightarrow> adjacent_nodes u \<noteq> {}"
      unfolding V_def adjacent_nodes_def by auto
    also have "\<dots> \<longleftrightarrow> am u \<noteq> []"
      using fun_relD[OF assms IdI[of u]]
      by (auto simp: list_set_rel_def in_br_conv)
    finally show ?thesis unfolding am_is_in_V_def by refine_vcg auto
  qed

end \<comment> \<open>Network Implementation Locale\<close>

subsubsection \<open>Registration of Basic Operations to Sepref\<close>

text \<open>Bundles the setup for registration of abstract operations.\<close>
bundle Network_Impl_Sepref_Register begin
  text \<open>Automatically rewrite to \<open>i_mtx\<close> interface type\<close>
  lemmas [map_type_eqs] =
    map_type_eqI[of "TYPE(capacity_impl flow)" "TYPE(capacity_impl i_mtx)"]

end \<comment> \<open>Bundle\<close>

context Network_Impl
begin

subsubsection \<open>Registration of Abstract Operations\<close>

context
  includes Network_Impl_Sepref_Register
begin

sepref_register N s t
sepref_register c :: "capacity_impl graph"

sepref_register cf_get cf_set cf_init

sepref_register am_get am_is_in_V

end \<comment> \<open>Anonymous Context\<close>

end \<comment> \<open>Network Implementation Locale\<close>

subsection \<open>Refinement To Efficient Data Structures\<close>

subsubsection \<open>Functions from Nodes by Arrays\<close>
(*
  TODO: Move to own file in IICF

  This has more general uses than implementing nodes!
  It can implement functions from any objects represented by an initial
  segment of the natural numbers, a very often recurring pattern.
*)
text \<open>
  We provide a template for implementing functions from nodes by arrays.
  Outside the node range, the abstract functions have a default value.

  This template is then used for refinement of various data structures.
\<close>
definition "is_nf N dflt f a
  \<equiv> \<exists>\<^sub>Al. a\<mapsto>\<^sub>al * \<up>(length l = N \<and> (\<forall>i<N. l!i = f i) \<and> (\<forall>i\<ge>N. f i = dflt))"

lemma nf_init_rule:
  "<emp> Array.new N dflt <is_nf N dflt (\<lambda>_. dflt)>"
  unfolding is_nf_def by sep_auto

lemma nf_copy_rule[sep_heap_rules]:
  "<is_nf N dflt f a> array_copy a <\<lambda>r. is_nf N dflt f a * is_nf N dflt f r>"
  unfolding is_nf_def by sep_auto

lemma nf_lookup_rule[sep_heap_rules]:
  "v<N \<Longrightarrow> <is_nf N dflt f a> Array.nth a v <\<lambda>r. is_nf N dflt f a *\<up>(r = f v)>"
  unfolding is_nf_def by sep_auto

lemma nf_update_rule[sep_heap_rules]:
  "v<N \<Longrightarrow> <is_nf N dflt f a> Array.upd v x a <is_nf N dflt (f(v:=x))>"
  unfolding is_nf_def by sep_auto

subsubsection \<open>Automation Setup for Side-Condition Discharging\<close>

context Network_Impl
begin

lemma mtx_nonzero_iff[simp]: "mtx_nonzero c = E"
  unfolding E_def by (auto simp: mtx_nonzero_def)

lemma mtx_nonzeroN: "mtx_nonzero c \<subseteq> {0..<N}\<times>{0..<N}" using E_ss by simp

lemma in_mtx_nonzeroN[simp]: "(u,v) \<in> mtx_nonzero c \<Longrightarrow> u<N \<and> v<N"
  using mtx_nonzeroN by auto

lemma inV_less_N[simp]: "v\<in>V \<Longrightarrow> v<N" using V_ss by auto

lemma inEIE_lessN[simp]: "e\<in>E \<or> e\<in>E\<inverse> \<Longrightarrow> case e of (u,v) \<Rightarrow> u<N \<and> v<N"
  using E_ss by auto
lemmas [simp] = nested_case_prod_simp

subsubsection \<open>Network Parameters by Identity\<close>
abbreviation (in -) cap_assn :: "capacity_impl \<Rightarrow> _" where "cap_assn \<equiv> id_assn"
abbreviation (in -) "edge_assn \<equiv> nat_assn \<times>\<^sub>a nat_assn"
abbreviation (in -) (input) "node_assn \<equiv> nat_assn"

text \<open>Refine number of nodes, and source and sink node by themselves\<close>
lemmas [sepref_import_param] =
  IdI[of N]
  IdI[of s]
  IdI[of t]

lemma c_hnr[sepref_fr_rules]:
  "(uncurry0 (return c),uncurry0 (RETURN c))
    \<in>unit_assn\<^sup>k \<rightarrow>\<^sub>a pure (nat_rel \<times>\<^sub>r nat_rel \<rightarrow> Id)"
  by (sepref_to_hoare) sep_auto

subsubsection \<open>Residual Graph by Adjacency Matrix\<close>

definition (in -) "cf_assn N \<equiv> asmtx_assn N cap_assn"
abbreviation cf_assn where "cf_assn \<equiv> Network_Impl.cf_assn N"
lemma [intf_of_assn]: "intf_of_assn (cf_assn) TYPE(capacity_impl i_mtx)"
  by simp

sepref_thm cf_get_impl is "uncurry (PR_CONST cf_get)"
  :: "cf_assn\<^sup>k *\<^sub>a edge_assn\<^sup>k \<rightarrow>\<^sub>a cap_assn"
  unfolding cf_get_def cf_assn_def PR_CONST_def
  by sepref
concrete_definition (in -) cf_get_impl
  uses Network_Impl.cf_get_impl.refine_raw is "(uncurry ?f,_)\<in>_"

sepref_thm cf_set_impl is "uncurry2 (PR_CONST cf_set)"
  :: "cf_assn\<^sup>d *\<^sub>a edge_assn\<^sup>k *\<^sub>a cap_assn\<^sup>k \<rightarrow>\<^sub>a cf_assn"
  unfolding cf_set_def cf_assn_def PR_CONST_def by sepref
concrete_definition (in -) cf_set_impl
  uses Network_Impl.cf_set_impl.refine_raw is "(uncurry2 ?f,_)\<in>_"

sepref_thm cf_init_impl is "uncurry0 (PR_CONST cf_init)"
  :: "unit_assn\<^sup>k \<rightarrow>\<^sub>a cf_assn"
  unfolding PR_CONST_def cf_assn_def cf_init_def
  apply (rewrite amtx_fold_custom_new[of N N])
  by sepref
concrete_definition (in -) cf_init_impl
  uses Network_Impl.cf_init_impl.refine_raw is "(uncurry0 ?f,_)\<in>_"
lemmas [sepref_fr_rules] =
  cf_get_impl.refine[OF Network_Impl_axioms]
  cf_set_impl.refine[OF Network_Impl_axioms]
  cf_init_impl.refine[OF Network_Impl_axioms]

subsubsection \<open>Adjacency Map by Array\<close>
definition (in -) "am_assn N \<equiv> is_nf N ([]::nat list)"
abbreviation am_assn where "am_assn \<equiv> Network_Impl.am_assn N"

lemma am_get_hnr[sepref_fr_rules]:
  "(uncurry Array.nth, uncurry (PR_CONST am_get))
  \<in> am_assn\<^sup>k *\<^sub>a node_assn\<^sup>k \<rightarrow>\<^sub>a list_assn id_assn"
  unfolding am_assn_def am_get_def list_assn_pure_conv
  by sepref_to_hoare (sep_auto simp: refine_pw_simps)

definition (in -) "am_is_in_V_impl am u \<equiv> do {
  amu \<leftarrow> Array.nth am u;
  return (\<not>is_Nil amu)
}"
lemma am_is_in_V_hnr[sepref_fr_rules]: "(uncurry am_is_in_V_impl, uncurry (am_is_in_V))
  \<in> [\<lambda>(_,v). v<N]\<^sub>a am_assn\<^sup>k *\<^sub>a node_assn\<^sup>k \<rightarrow> bool_assn"
  unfolding am_assn_def am_is_in_V_def am_is_in_V_impl_def
  apply sepref_to_hoare
  apply (sep_auto simp: refine_pw_simps split: list.split)
  done

end \<comment> \<open>Network Implementation Locale\<close>

subsection \<open>Computing the Flow Value\<close>
text \<open>We define an algorithm to compute the value of a flow from
  the residual graph
\<close>

locale RGraph_Impl = RGraph c s t cf + Network_Impl c s t N
  for c :: "capacity_impl flow" and s t N cf

lemma rgraph_and_network_impl_imp_rgraph_impl:
  assumes "RGraph c s t cf"
  assumes "Network_Impl c s t N"
  shows "RGraph_Impl c s t N cf"
  using assms by (rule Network_Impl.RGraph_Impl.intro)

lemma (in RGraph) val_by_adj_map:
  assumes AM: "is_adj_map am"
  shows "f.val = (\<Sum>v\<in>set (am s). cf (v,s))"
proof -
  have [simp]: "set (am s) = E``{s}"
    using AM unfolding is_adj_map_def
    by auto

  note f.val_by_cf
  also note rg_is_cf
  also have "(\<Sum>(u, v)\<in>outgoing s. cf (v, u))
          = ((\<Sum>v\<in>set (am s). cf (v,s)))"
    by (simp add: sum_outgoing_pointwise)
  finally show ?thesis .
qed

context Network_Impl
begin

definition "compute_flow_val_aux am cf \<equiv> do {
    succs \<leftarrow> am_get am s;
    sum_impl (\<lambda>v. cf_get cf (v,s)) (set succs)
  }"

lemma (in RGraph_Impl) compute_flow_val_aux_correct:
  assumes "is_adj_map am"
  shows "compute_flow_val_aux am cf \<le> (spec v. v = f.val)"
  unfolding val_by_adj_map[OF assms]
  unfolding compute_flow_val_aux_def cf_get_def am_get_def
  apply (refine_vcg sum_impl_correct)
  apply (vc_solve simp: s_node)
  subgoal using assms unfolding is_adj_map_def by auto
  done

text \<open>For technical reasons (poor foreach-support of Sepref tool),
  we have to add another refinement step: \<close>
definition "compute_flow_val am cf \<equiv> (do {
  succs \<leftarrow> am_get am s;
  nfoldli succs (\<lambda>_. True) (\<lambda>x a. do {
     b \<leftarrow> cf_get cf (x, s);
     return (a + b)
   }) 0
})"

lemma (in RGraph_Impl) compute_flow_val_correct[THEN order_trans, refine_vcg]:
  assumes "is_adj_map am"
  shows "compute_flow_val am cf \<le> (spec v. v = f.val)"
proof -
  have [refine_dref_RELATES]: "RELATES (\<langle>Id\<rangle>list_set_rel)"
    by (simp add: RELATES_def)
  show ?thesis
    apply (rule order_trans[OF _ compute_flow_val_aux_correct[OF assms]])
    unfolding compute_flow_val_def compute_flow_val_aux_def sum_impl_def
    apply (rule refine_IdD)
    apply (refine_rcg LFO_refine bind_refine')
    apply refine_dref_type
    apply vc_solve
    using assms
    by (auto
        simp: list_set_rel_def br_def am_get_def is_adj_map_def
        simp: refine_pw_simps)
qed

context
  includes Network_Impl_Sepref_Register
begin
  sepref_register compute_flow_val
end

sepref_thm compute_flow_val_impl
  is "uncurry (PR_CONST compute_flow_val)"
    :: "am_assn\<^sup>k *\<^sub>a cf_assn\<^sup>k \<rightarrow>\<^sub>a cap_assn"
  unfolding compute_flow_val_def PR_CONST_def
  by sepref
concrete_definition (in -) compute_flow_val_impl
  uses Network_Impl.compute_flow_val_impl.refine_raw is "(uncurry ?f,_)\<in>_"
lemmas compute_flow_val_impl_hnr[sepref_fr_rules]
    = compute_flow_val_impl.refine[OF Network_Impl_axioms]

end \<comment> \<open>Network Implementation Locale\<close>

text \<open>We also export a correctness theorem on the separation logic level\<close>

lemma compute_flow_val_impl_correct[sep_heap_rules]:
  assumes "RGraph_Impl c s t N cf"
  assumes AM: "Graph.is_adj_map c am"
  shows "<cf_assn N cf cfi * am_assn N am ami>
          compute_flow_val_impl s N ami cfi
        <\<lambda>v. cf_assn N cf cfi * am_assn N am ami
            * \<up>( v = Flow.val c s (RPreGraph.f c cf) )>\<^sub>t"
proof -
  interpret RGraph_Impl c s t N cf by fact

  from hn_refine_ref[OF
      compute_flow_val_correct[OF AM order_refl]
      compute_flow_val_impl_hnr[to_hnr, unfolded autoref_tag_defs]]
  show ?thesis
    apply (simp add: hn_ctxt_def pure_def hn_refine_def f_def)
    apply (rule cons_post_rule)
    apply assumption
    apply sep_auto
    done
qed

subsubsection \<open>Computing the Exact Number of Nodes\<close>

context Network_Impl
begin

lemma am_to_adj_nodes_refine:
  assumes AM: "is_adj_map am"
  shows "(am u, adjacent_nodes u) \<in> \<langle>nat_rel\<rangle>list_set_rel"
  using AM
  unfolding adjacent_nodes_def is_adj_map_def
  by (auto simp: list_set_rel_def in_br_conv)

definition "init_C am \<equiv> do {
  let cardV=0;
  nfoldli [0..<N] (\<lambda>_. True) (\<lambda>v cardV. do {
    assert (v<N);
    inV \<leftarrow> am_is_in_V am v;
    if inV then do {
      return (cardV + 1)
    } else
      return cardV
  }) cardV
}"

lemma init_C_correct:
  assumes AM: "is_adj_map am"
  shows "init_C am \<le> SPEC (\<lambda>C. C = card V)"
  unfolding init_C_def
  apply (refine_vcg
      nfoldli_rule[where I="\<lambda>l1 _ C. C = card (V\<inter>set l1)"]
      )
  apply clarsimp_all
  using V_ss
  apply (auto simp: upt_eq_lel_conv Int_absorb2 am_to_adj_nodes_refine[OF AM])
  done

context
  includes Network_Impl_Sepref_Register
begin
  sepref_register init_C
end

sepref_thm fifo_init_C_impl is "(PR_CONST init_C)"
    :: "am_assn\<^sup>k \<rightarrow>\<^sub>a nat_assn"
  unfolding init_C_def PR_CONST_def
  by sepref
concrete_definition (in -) fifo_init_C_impl
  uses Network_Impl.fifo_init_C_impl.refine_raw is "(?f,_)\<in>_"
lemmas [sepref_fr_rules] = fifo_init_C_impl.refine[OF Network_Impl_axioms]

end \<comment> \<open>Network Implementation Locale\<close>

end