theory SchnelleinstiegHOL
  imports Main BeispielTac
begin

section\<open>Schnelleinstieg Isabelle/HOL\<close>

subsection\<open>Beweise\<close>
text\<open>Die besondere Fähigkeit im Beweisassistent Isabelle/HOL liegt darin,
maschinengeprüfte Beweise zu machen.

Beispiel:\<close>

lemma \<open>3 = 2+1\<close> by simp

text\<open>In der PDFversion wird der eigentliche Beweis ausgelassen.
Aber keine Sorge, der Computer hat den Beweis überprüft.
Würde der Beweis nicht gelten, würde das PDF garnicht compilieren.

Ich wurde schon für meine furchtbaren Beweise zitiert.
Ist also ganz gut, dass wir nur Ergebnisse im PDF sehen und der eigentliche Beweis ausgelassen ist.
Am besten kann man Beweise sowieso im Isabelle Editor anschauen und nicht im PDF.

Wir werden die meisten Hilfsfakten als @{command lemma} kennzeichnen.
Wichtige Fakten werden wir @{command theorem} nennen.
Zusätzlich führen wir noch das @{command beispiel} Kommando ein,
um Lemmata von Beispielen zu unterscheiden.

Folgende drei Aussagen sind alle equivalent und maschinengeprüft korrekt:
\<close>

lemma \<open>3 = 2+1\<close> by simp
theorem \<open>3 = 2+1\<close> by simp
beispiel \<open>3 = 2+1\<close> by simp

text\<open>Freitext, so wie der aktuelle Satz, sind nicht (oder nur minimal) maschinell geprüft.\<close>

subsection\<open>Typen\<close>
text\<open>Typen werden per \<^verbatim>\<open>::\<close> annotiert.
Beispielsweise sagt \<^theory_text>\<open>3::nat\<close>, dass \<^term>\<open>3::nat\<close> eine natürliche Zahl (Typ \<^typ>\<open>nat\<close>) ist.\<close>

text\<open>Einige vordefinierte Typen in Isabelle/HOL:

  \<^item> Natürliche Zahlen. Typ \<^typ>\<open>nat\<close>.
    Beispielsweise  \<^term_type>\<open>0 :: nat\<close>, \<^term_type>\<open>1 :: nat\<close>,
    \<^term_type>\<open>2 :: nat\<close>, \<^term_type>\<open>3 :: nat\<close>.
    Auf natürlichen Zahlen ist die Nachfolgerfunktion \<^const>\<open>Suc\<close> definiert.
    Beispielsweise ist @{lemma \<open>Suc 2 = 3\<close> by simp}.
  \<^item> Ganze Zahlen. Typ \<^typ>\<open>int\<close>.
    Beispielsweise  \<^term_type>\<open>0 :: int\<close>, \<^term_type>\<open>1 :: int\<close>,
    \<^term_type>\<open>-1 :: int\<close>, \<^term_type>\<open>-42 :: int\<close>.
  \<^item> Listen. Typ \<^typ>\<open>'\<alpha> list\<close>.
    Beispielsweise  \<^term_type>\<open>[] :: nat list\<close>, \<^term_type>\<open>[] :: int list\<close>,
    \<^term_type>\<open>[0, 1, 2, 3] :: nat list\<close>, \<^term_type>\<open>[0, 1, -1, -42] :: int list\<close>.
  \<^item> Strings. Typ \<^typ>\<open>string\<close>.
    Beispielsweise  \<^term_type>\<open>''Hello, World'' :: string\<close>.
\<close>

subsection\<open>Mehr Typen\<close>
text\<open>Jeder Typ der mit einem einfachen Anführungszeichen anfängt ist ein polymorpher Typ.
Beispiel: \<^typ>\<open>'a\<close> oder \<^typ>\<open>'\<alpha>\<close>.
So ein Typ ist praktisch ein generischer Typ,
welcher durch jeden anderen Typen instanziiert werden kann.

Beispielsweise steht \<^typ>\<open>'nat\<close> für einen beliebigen Typen,
während \<^typ>\<open>nat\<close> der konkrete Typ der natürlichen Zahlen ist.

Wenn wir nun \<^theory_text>\<open>3::'a\<close> schreiben handelt es sich nur um das generische Numeral 3.
Das ist so generisch, dass z.B. noch nicht einmal die Plusoperation darauf definiert ist.
Im Gegensatz dazu ist \<^theory_text>\<open>3::nat\<close> die natürliche Zahl 3,
mit allen wohlbekannten Rechenoperationen.
Im Beweis obigen \<^theory_text>\<open>lemma\<open>3 = 2+1\<close>\<close> hat Isabelle die Typen automatisch inferiert.
\<close>

subsection\<open>Noch mehr Typen\<close>
text\<open>Eigene Typen können unter Anderem mit dem Keyword @{command datatype} eingeführt werden.
Im folgenden Beispiel führen wir einen @{command datatype} für Farben ein.\<close>

datatype beispiel_farbe = Rot | Gruen | Blau

text\<open>Eine variable \<^term_type>\<open>x :: beispiel_farbe\<close> kann entweder den Wert
\<^const>\<open>Rot\<close>, \<^const>\<open>Gruen\<close>, oder \<^const>\<open>Blau\<close> haben.
Dies lässt sich auch beweisen:\<close>

beispiel\<open>x = Rot \<or> x = Gruen \<or> x = Blau\<close>
  by(cases \<open>x\<close>, auto)

text\<open>Wir können auch einen Schritt weitergehen und eine Liste von \<^typ>\<open>beispiel_farbe\<close>
selbst implementieren.\<close>

datatype beispiel_farbe_liste = FLLeer | FLKopf \<open>beispiel_farbe\<close> \<open>beispiel_farbe_liste\<close>

text\<open>Eine \<^typ>\<open>beispiel_farbe_liste\<close> ist hier rekursiv definiert:

  \<^item> Entweder ist die Liste \<^const>\<open>FLLeer\<close> und enthält keine Elemente.
  \<^item> Oder es gibt bereits eine \<^typ>\<open>beispiel_farbe_liste\<close> und über den \<^const>\<open>FLKopf\<close>
    Konstruktor hängen wir eine weitere \<^typ>\<open>beispiel_farbe\<close> an.
    Die Abkürzung \<^const>\<open>FLKopf\<close> steht hier für Farben-Listen-Kopf.

Beispielsweise können wir immer länger werdende
\<^typ>\<open>beispiel_farbe_liste\<close>n welche nur \<^const>\<open>Rot\<close>e Elemente enthalten wie folgt konstruieren:

  \<^item> \<^term>\<open>(FLLeer) :: beispiel_farbe_liste\<close> enthält 0 Elemente.
  \<^item> \<^term>\<open>(FLKopf Rot FLLeer) :: beispiel_farbe_liste\<close> enthält ein \<^const>\<open>Rot\<close> Element.
  \<^item> \<^term>\<open>(FLKopf Rot (FLKopf Rot FLLeer)) :: beispiel_farbe_liste\<close>
     enthält zwei \<^const>\<open>Rot\<close> Elemente.
  \<^item> \<^term>\<open>(FLKopf Rot (FLKopf Rot (FLKopf Rot FLLeer))) :: beispiel_farbe_liste\<close>
     enthält drei \<^const>\<open>Rot\<close> Elemente.
\<close>

text\<open>Das Konzept Liste kann weiter verallgemeinert werden.
Wir können eine generische Liste bauen, welche nicht nur \<^typ>\<open>beispiel_farbe\<close>n aufnehmen kann,
sondern eine polymorphe Liste,
welche beliebige Typen speichern kann.
\<close>

datatype '\<alpha> beispiel_liste = Leer | Kopf \<open>'\<alpha>\<close> \<open>'\<alpha> beispiel_liste\<close>

text\<open>Der Typ \<^typ>\<open>'\<alpha>\<close> steht hierbei für einen Platzhalter für beliebige Typen.
Beispielsweise können wir mit der generischen \<^typ>\<open>'\<alpha> beispiel_liste\<close> wieder unsere
\<^typ>\<open>beispiel_farbe_liste\<close> simulieren:

  \<^item> \<^term_type>\<open>(Leer) :: beispiel_farbe beispiel_liste\<close> enthält 0 Elemente.
  \<^item> \<^term_type>\<open>(Kopf Rot Leer) :: beispiel_farbe beispiel_liste\<close>
    enthält ein \<^const>\<open>Rot\<close> Element.
  \<^item> \<^term_type>\<open>(Kopf Rot (Kopf Rot Leer)) :: beispiel_farbe beispiel_liste\<close>
     enthält zwei \<^const>\<open>Rot\<close> Elemente.
  \<^item> \<^term_type>\<open>(Kopf Rot (Kopf Rot (Kopf Rot Leer))) :: beispiel_farbe beispiel_liste\<close>
     enthält drei \<^const>\<open>Rot\<close> Elemente.

Die Liste kann jedoch auch andere Typen von Elementen speichern.

  \<^item> \<^term_type>\<open>(Kopf 2 (Kopf 1 (Kopf 0 Leer))) :: nat beispiel_liste\<close>
  \<^item> \<^term_type>\<open>(Kopf ''Erstes Element'' (Kopf ''Letzes Element'' Leer)) :: string beispiel_liste\<close>
\<close>

text\<open>Die Länge einer \<^typ>\<open>'\<alpha> beispiel_liste\<close> lässt sich über folgende rekursive Funktion
wie folgt definieren:\<close>

fun beispiel_liste_laenge :: \<open>'\<alpha> beispiel_liste \<Rightarrow> nat\<close> where
  \<open>beispiel_liste_laenge Leer = 0\<close>
| \<open>beispiel_liste_laenge (Kopf _ ls) = Suc (beispiel_liste_laenge ls)\<close>

text\<open>Funktionen werden oft über Pattern-Matching implementiert,
d.h., dass der gegebene Datentyp zerlegt wird und eine Fallunterscheidung getroffen wird.

  \<^item> Für den Basisfall \<^const>\<open>Leer\<close> wird \<^term>\<open>0::nat\<close> zurückgegeben.
  \<^item> Für den rekursiven Fall \<^term>\<open>Kopf\<close> in dem wir ein Kopfelement haben
    welches wir ignorieren und einer Folgeliste \<^term>\<open>ls::'\<alpha> beispiel_liste\<close>
    rufen wir \<^const>\<open>beispiel_liste_laenge\<close> rekursiv mit der Folgeliste auf und geben den
    Nachfolger der so berechneten Zahl zurück.\<close>

beispiel \<open>beispiel_liste_laenge Leer = 0\<close>
  by eval
beispiel \<open>beispiel_liste_laenge (Kopf Rot (Kopf Rot (Kopf Rot Leer))) = 3\<close>
  by eval

text\<open>Zusätzlich können den einzelnen Feldern in Datentypen spezielle Namen gegeben werden.
Beispielsweise:\<close>

datatype '\<alpha> beispiel_liste_mit_namen =
    LeerMN | KopfMN (kopfelement: \<open>'\<alpha>\<close>) (schwanzliste: \<open>'\<alpha> beispiel_liste_mit_namen\<close>)

text\<open>Der Fall \<^const>\<open>LeerMN\<close> bleibt unverändert.
Um Verwechslung zu vermeiden haben wir den einzelnen Fällen das Suffix MN (Mit-Namen)
gegeben, da die Konstruktoren \<^const>\<open>Leer\<close> und \<^const>\<open>Kopf\<close> bereits durch das vorherige Beispiel
definiert sind.
Im \<^const>\<open>KopfMN\<close>-Fall haben nun die einzelnen Felder Namen.\<close>

beispiel\<open>kopfelement (KopfMN Rot LeerMN) = Rot\<close> by simp
beispiel\<open>schwanzliste (KopfMN Rot LeerMN) = LeerMN\<close> by simp

text\<open>Die von Isabelle mitgelieferte Standardimplementierung einer Liste
sieht unserem Beispiel recht ähnlich,
allerdings liefert Isabelle noch zusätzlichen Syntactic Sugar um Listen komfortabler darzustellen.
Die Implementierung einer Liste in der Standardbibliothek ist: \<^datatype>\<open>list\<close>\<close>

subsection\<open>Funktionen\<close>
text\<open>Beispiel:
Eine Funktionen welche eine natürliche Zahl nimmt und
eine natürliche Zahl zurück gibt (\<^typ>\<open>nat \<Rightarrow> nat\<close>):\<close>

fun beispielfunktion :: \<open>nat \<Rightarrow> nat\<close> where
  \<open>beispielfunktion n = n + 10\<close>

text\<open>Funktionsaufrufe funktionieren ohne Klammern.\<close>

beispiel \<open>beispielfunktion 32 = 42\<close> by eval

text\<open>Funktionen sind gecurried. Hier ist eine Funktion welche 2 natürliche Zahlen nimmt
und eine natürliche Zahl zurück gibt (\<^typ>\<open>nat \<Rightarrow> nat \<Rightarrow> nat\<close>):\<close>
fun addieren :: \<open>nat \<Rightarrow> nat \<Rightarrow> nat\<close> where
  \<open>addieren a b = a + b\<close>

beispiel \<open>addieren 32 10 = 42\<close> by eval

text\<open>Currying bedeutet auch, wenn wir \<^const>\<open>addieren\<close> nur mit einem Argument aufrufen
(welches eine natürliche Zahl \<^typ>\<open>nat\<close> sein muss),
dass wir eine Funktion zurückbekommen, die noch das zweite Argument erwartet,
bevor sie das Ergebnis zurückgeben kann.

Beispiel: \<^term_type>\<open>(addieren 10) :: (nat \<Rightarrow> nat)\<close>

Zufälligerweise ist \<^term>\<open>addieren 10\<close> equivalent zu \<^term>\<open>beispielfunktion\<close>:
\<close>
beispiel \<open>addieren 10 = beispielfunktion\<close>
  by(simp add: fun_eq_iff)

text\<open>Zusätzlich lassen sich Funktionen im Lambda Calculus darstellen.
Beispiel:\<close>

beispiel \<open>(\<lambda>n::nat. n+10) 3 = 13\<close> by eval

beispiel \<open>beispielfunktion = (\<lambda>n. n+10)\<close>
  by(simp add: fun_eq_iff)

text\<open>Im vorhergehenden Beispiel wurden zwei Funktionen
(die \<^const>\<open>beispielfunktion\<close> die wir oben definiert haben und ein lambda-Ausdruck)
als equivalent bewiesen.
Dafür wurde die Extensionalität verwendet.\<close>

subsection\<open>Mengen\<close>
text\<open>Mengen funktionieren wie normale mathematische Mengen.

Beispiel. Die Menge der geraden Zahlen:
\<close>
beispiel \<open>{0,2,4,6,8,10,12} \<subseteq> {n::nat. n mod 2 = 0}\<close>
  by(simp)

beispiel \<open>{0,2,4,6,8,10} = {n::nat. n mod 2 = 0 \<and> n \<le> 10}\<close>
  by fastforce

text\<open>Bei vorherigen Beispiel können wir das Prinzip der (mathematischen) \<^emph>\<open>Extensionalität\<close> sehen:
Intensional sind die beiden Mengen \<^term>\<open>{0,2,4,6,8,10}::nat set\<close> und \<^term>\<open>{n::nat. n mod 2 = 0 \<and> n \<le> 10}\<close>
verschieden, da sie unterschiedlich definiert sind.
Extensional betrachtet, sind die beiden Mengen jedoch gleich,
da sie genau die gleichen äußeren Eigenschaften haben,
d.h. da sie genau die gleichen Elemente enthalten.\<close>

subsection\<open>First-Order Logic\<close>
text\<open>First-Order Logic, oder auch Prädikatenlogik erster Stufe, besteht aus folgenden Symbolen.

  \<^item> Konjunktion. Der Term \<^term>\<open>A \<and> B\<close> besagt, dass sowohl \<^term>\<open>A\<close> als auch \<^term>\<open>B\<close> wahr sind.
    Dies entspricht dem logischen "Und".
  \<^item> Disjunktion. Der Term \<^term>\<open>A \<or> B\<close> besagt, dass \<^term>\<open>A\<close> oder \<^term>\<open>B\<close> (oder beide) wahr sind.
    Dies entspricht dem logischen "Oder".
  \<^item> Negation. Der Term \<^term>\<open>\<not> A\<close> besagt, dass \<^term>\<open>A\<close> nicht wahr ist.
    Dies entspricht dem logischen "Nicht".
  \<^item> Implikation. Der Term \<^term>\<open>A \<longrightarrow> B\<close> besagt, dass wenn \<^term>\<open>A\<close> gilt dann gilt auch \<^term>\<open>B\<close>.
    Dies entspricht dem logischen "Wenn-Dann".
    Unsere Mathematik ist hardcore klassisch und es gilt
    @{lemma [break=true] \<open>A \<longrightarrow> B \<longleftrightarrow> \<not>A \<or> B\<close> by blast}.
  \<^item> All-Quantifier. Der Term \<^term>\<open>\<forall>x. P x\<close> besagt, dass \<^term>\<open>P x\<close> wahr ist für alle \<^term>\<open>x\<close>.
    Dies entspricht dem logischen "Für-Alle".
  \<^item> Existenz-Quantifier. Der Term \<^term>\<open>\<exists>x. P x\<close> besagt, dass es ein \<^term>\<open>x\<close> gibt,
    für das \<^term>\<open>P x\<close> gilt.
    Dies entspricht dem logischen "Es-Existiert".
  \<^item> Des Weiteren gibt es noch die Abkürzung @{term [source=true] \<open>A \<longleftrightarrow> B\<close>}, welche bedeutet,
    dass \<^term>\<open>A\<close> genau dann gilt wenn \<^term>\<open>B\<close> gilt.
    Dies entspricht dem logischen "Genau-Dann-Wenn".
    Genau genommen ist @{term [source=true] \<open>A \<longleftrightarrow> B\<close>} eine Abkürzung für \<^term>\<open>A = B\<close>.
    Oft ist @{term [source=true] \<open>A \<longleftrightarrow> B\<close>} praktischer zu schreiben, da es schwächer bindet.
    Genau genommen gilt @{lemma [source=true] \<open>(A \<longleftrightarrow> B) = ((A) = (B))\<close> by blast}.
    Die schwache Bindung von @{term [source=true] \<open>A \<longleftrightarrow> B\<close>} wird dann relevant,
    wenn \<^term>\<open>A\<close> und \<^term>\<open>B\<close> komplizierte Ausdrücke sind,
    da wir uns im Gegensatz zu @{term [source=true] \<open>(A) = (B)\<close>} Klammern sparen können.
\<close>

subsection\<open>Higher-Order Logic (HOL)\<close>
text\<open>First-Order Logic ist in Higher-Order Logic eingebettet.
Higher-Order Logic (HOL) ist die native Sprache von Isabelle/HOL.
Im Vergleich zur First-Order Logic besteht HOL nur aus zwei essentiellen Symbolen:

  \<^item> All-Quantifier. Der Term \<^term>\<open>\<And>x. P x\<close> besagt \<^term>\<open>\<forall>x. P x\<close>.
    Eigentlich ist zwischen dem First-Order und dem Higher-Order All-Quantifier kein
    wesentlicher Unterschied.
    Genau genommen lässt sich der First-Order All-Quantifier via HOL einführen wie folgt:
    @{thm allI}.

    Da mathematisch der Ausdruck \<^term>\<open>P x\<close> besagt, dass \<^term>\<open>P\<close> für
    beliebiges \<^term>\<open>x\<close>---sprich: alle \<^term>\<open>x\<close>---
    gilt, ist folgendes equivalent:
      \<^item> \<^term>\<open>\<And>x. P x\<close>
      \<^item> \<^term>\<open>\<forall>x. P x\<close>
      \<^item> \<^term>\<open>P x\<close>
  \<^item> Implikation. Der Term \<^term>\<open>A \<Longrightarrow> B\<close> besagt \<^term>\<open>A \<longrightarrow> B\<close>.
    Eigentlich ist zwischen der First-Order und der Higher-Order Implikation kein
    wesentlicher Unterschied.

    Die Implikation assoziiert nach rechts.
    Dies bedeutet @{lemma [source=true] \<open>A \<longrightarrow> B \<longrightarrow> C \<longleftrightarrow> (A \<longrightarrow> (B \<longrightarrow> C))\<close> by blast}.

    Logisch gilt damit auch folgendes:
    @{lemma [source=true] \<open>A \<longrightarrow> B \<longrightarrow> C \<longleftrightarrow> A \<and> B \<longrightarrow> C\<close> by blast}.

    In Isabelle/HOL werden wir viele Lemmata der Form @{term [source=true] \<open>A \<Longrightarrow> B \<Longrightarrow> C\<close>} sehen,
    welche zu lesen sind als: Aus \<^term>\<open>A\<close> und \<^term>\<open>B\<close> folgt \<^term>\<open>C\<close>.
    Dies ist gleichbedeutend mit \<^term>\<open>A \<and> B \<Longrightarrow> C\<close>.
    Da die Higher-Order Implikation einer der Kernbausteine von HOL sind ist die Formulierung
    welche nur die Implikation verwendet sehr praktisch für Isabelle.
\<close>

subsection\<open>Über Isabelle/HOL\<close>
text\<open>Isabelle/HOL ist ein interaktiver Beweisassistent und kann
von \<^url>\<open>https://isabelle.in.tum.de/\<close> bezogen werden.

Isabelle stammt aus der Tradition der LCF (Logic for Computable Functions) Theorembeweiser.
Die Standardlogik ist Higher-Order Logic (HOL), welche auf der klassischen Mathematik basiert.

Isabelle basiert auf einem mathematischen Microkernel.
Zum aktuellen Zeitpunkt mit Isabelle2022 befindet sich das Herzstück dieses mathematischen
Microkernels in der Datei \<^file>\<open>~~/src/Pure/thm.ML\<close>, welche aus nur ca 2500 Zeilen ML Code besteht.
Dies ist relativ wenig Code welchem wir vertrauen müssen.
Die Korrektheit aller Ergebnisse und Beweise dieser Theory hängen nur von der Korrektheit dieses
Microkernels ab.

Isabelle/HOL ist ein interaktiver Beweisassistent, was bedeutet,
Isabelle hilft einem Benutzer dabei Beweise zu schreiben.
Alle Beweise müssen von Isabelles Microkernel akzeptiert werden, welcher die Korrektheit garantiert.
Im Gegensatz zu interaktiven Beweisassistenten gibt es auch automatische Theorembeweiser,
wie z.B. Z3.
Z3 besteht aus mehreren hunderttausend Zeilen C Code (\<^url>\<open>https://github.com/Z3Prover/z3\<close>)
und ist damit im Vergleich zu Isabelles Microkernel riesig.
Dies bedeutet auch, dass einer riesige Menge an Code vertraut werden muss,
um einem Beweis von Z3 zu vertrauen.
Glücklicherweise arbeiten Isabelle und z.B. Z3 sehr gut zusammen:
Z3 kann losgeschickt werden um einen Beweis zu suchen.
Sobald Z3 meldet, dass ein Beweis gefunden wurde,
akzeptiert Isabelle diesen jedoch nicht blind,
sondern Isabelle akzeptiert den gefundenen Beweis nur,
wenn der Beweis sich gegen Isabelles Microkernel wiedergeben lässt.
Somit kombiniert Isabelle das Beste aus vielen Welten:
Die starke Korrektheitsgarantie eines mathematischen Microkernels der LCF Reihe
mit der Automatisierung der neuesten Generationen von automatischen Theorembeweisern.

Der Unterschied zwischen z.B. Z3 und Isabelle/HOL zeigt sich auch in einigen Beispielen:
Während der Z3 Bugtracker sehr viele Soundness Issues zeigt,
d.h. Fälle in denen Z3 etwas falsches beweisen hat,
hat es meines Wissens nach im Isabelle/HOL Kernel in über 30 Jahren keinen logischen Fehler gegeben,
welcher normale Benutzer betroffen hat.
Natürlich gab es auch in Isabelle/HOL Bugs und in künstlich geschaffenen Grenzfällen
konnte Isabelle überzeugt werden einen falschen Fakt zu akzeptieren,
jedoch handelt es sich hier um wenige Einzelfälle welche speziell konstruiert wurden
um Isabelle anzugreifen -- kein einziger Bug hat unter normalen Umständen zu logischer
Inkonsistenz geführt.
Umgekehrt ist Z3 schnell und automatisch.
Während Isabelle vom Benutzer verlangt, dass Beweise manuell gefunden und formalisiert
werden müssen kann Z3 teils extrem komplizierte Probleme schnell und automatisch lösen.

Isabelle integriert nicht nur mit automatischen Beweisern wie Z3,
Isabelle integriert auch mit automatischen Gegenbeispielsfindern,
wie z.B. @{command quickcheck} oder @{command nitpick}.
Dies bedeutet, sobald der Benutzer einen vermeintlichen Fakt in Isabelle eintippt,
schickt Isabelle Prozesse los um ein Gegenbeispiel zu finden.
Diese so gefundenen Gegenbeispiele sind oft unintuitiv.
Allerdings sind es echte Gegenbeispiele und der Computer erweist sich als
grausamer unnachgiebiger Diskussionspartner.
Dies führt dazu, dass wir nicht mit halbgaren oberflächlichen Argumenten durchkommen.
Oft eröffnen diese automatischen Gegenbeispiele auch eine neue Sicht auf die Dinge
und helfen, die eigenen impliziten Annahmen zu erkennen und zu hinterfragen.
Der Computer erweist sich hier als perfekter logischer geduldiger Diskussionspartner,
denn
"der wahre Philosoph ist gewillt, alle vorgefaßten Meinungen einer Prüfung zu unterziehen"
@{cite russellphi}.
Und da alle Fakten welche wir ultimativ als wahr behaupten wollen durch den mathematischen
Microkernel müssen, sind logische Flüchtigkeitsfehler in unserer Argumentation ausgeschlossen.
Allerdings können wir immer noch falsche Annahmen aufstellen,
auf welche wir unsere Ergebnisse stützen.
Jedoch müssen wir diese Annahmen explizit treffen und aufschreiben,
denn sonst ließe sich nichts beweisen.
\<close>

subsection\<open>Ist das KI?\<close>
text\<open>Nein!

Dieser Abschnitt ist etwas opinionated und handwavy.
Wenn aktuell von Künstlicher Intelligenz (KI) gesprochen wird,
wird damit oft Machine Learning gemeint.
Ich kürze Machine Learning absichtlich nicht mit ML ab,
da die Verwechslung mit der Programmiersprache Standard Meta Language (ML)
\<^url>\<open>https://de.wikipedia.org/wiki/Standard_ML\<close>
zu groß ist.
Isabelle ist in ML geschrieben und wenn im Umfeld von Isabelle von ML geredet wird,
ist meistens nie Machine Learning gemeint.
Genau genommen benutzt Isabelle die Poly/ML Implementierung,
welche das tollste Logo aller Programmiersprachen hat.\<close>

text_raw\<open>
  \begin{center}
    \includegraphics[height=0.15\textwidth]{Poly_Parrot3.png}\\
    Poly/ML Logo von polyml.org
  \end{center}
\<close>

text\<open>
Zurück zum Machine Learning.
Eine der aktuell beliebtesten Implementierungen für maschinelles Lernen sind neuronale Netze.
Dabei wird ein Algorithmus mit einer Unmenge an Trainingsdaten gefüttert,
um ein sogenanntes neuronales Netzwerk zu trainieren.
Ist so ein riesiges Netzwerk einmal trainiert ist es quasi unmöglich auf eine einzelne Zahl
im trainierten Netzwerk zu zeigen und zu verstehen
warum das Netz an genau dieser Stelle diese Zahl hat.
Der Einsatz solcher Methoden um moralische Entscheidungen zu treffen ist meiner Meinung nach
zurecht umstritten.
Insbesondere da die Ausgaben eines neuronalen Netzes auf den Trainingsdaten beruhen.
Wenn die Trainingsdaten bereits von versteckten Vorurteilen durchsetzt sind,
werden diese natürlich auch in das Netz übernommen.

Unser Ansatz der Modellierung in einem Theorembeweiser ist grundverschieden von
Entscheidungsfindungsansätzen basierend auf Machine Learning.

  \<^item> \<^emph>\<open>Axiomatische Grundlage\<close>.
    Machine Learning basiert auf den Trainingsdaten.
    Wenn ein neuronales Netzwerk auf mehreren Milliarden Trainingsdaten basiert,
    ließe sich ketzerisch sagen,
    dass das logische System auf mehreren Milliarden Axiomen beruht.
    Diese Axiomatische Grundlage kann schnell inkonsistent werden
    und es ist unmöglich diese riesige Menge an Axiomen zu hinterfragen.

    Im Gegensatz dazu steht die Anzahl der Axiome in Isabelle/HOL.
    Es handelt sich größtenteils um die gewöhnlichen Axiome der klassischen Mathematik,
    über die sich klassische Mathematiker größtenteils seit über 100 Jahren einig sind
    (\<^url>\<open>https://en.wikipedia.org/wiki/Axiom_of_choice\<close> sagt
    "The axiom of choice was formulated in 1904 by Ernst Zermelo").
    Auch ist die Anzahl der Axiome minimal.
    Wenn wir die Isabelle Sources nach dem Kommando @{command axiomatization} durchsuchen,
    finden wir außerhalb von Beispielen nur eine Hand voll Axiomen.
    In diesem Artikel verwenden wir das Kommando @{command axiomatization} gar nicht.
    Hinzu kommen noch axiomatische Konstruktionen,
    wobei jede solche Konstruktion jedoch sehr genau auf ihre Korrektheit geprüft wurde.
    In diesem Artikel führen wir keine neuen axiomatischen Konstruktionen ein
    und verlassen uns komplett auf die Konstruktionen der Standardbibliothek,
    wie z.B. @{command datatype} oder @{command fun}.
  \<^item> \<^emph>\<open>Nachvollziehbarkeit der Ergebnisse\<close>.
    Während es bei einem großen neuronalen Netz nahezu unmöglich ist zu verstehen warum ein
    bestimmter Wert an einer bestimmten Stelle steht und was dies zu bedeuten hat,
    lässt sich dieses Dokument immer wieder neu kompilieren und alle Beweise wiederholen.
    Dabei ließe sich genau nachvollziehen wie ein Fakt es in den Isabelle Microkernel geschafft hat.
    Zusätzlich stellt Isabelle diverse \<^verbatim>\<open>trace\<close> Kommandos bereit.
    Es lässt sich also nachvollziehen, warum etwas gilt.
  \<^item> \<^emph>\<open>Vertrauen in die Ergebnisse\<close>.
    Wie bereits erwähnt basiert Isabelle auf einem mathematischen Microkernel,
    wodurch ein extrem hohes Vertrauen in alle Ergebnisse erzielt wird.

Allerdings darf Machine Learning uns natürlich beim Beweise- und Gegenbeispiel-Finden helfen;
so angebunden wie automatisierte Beweiser wie Z3.
Das bedeutet, Machine Learning hilft bei der Entwicklung,
trifft jedoch selbst keine Entscheidungen und alle Ergebnisse werden von
Isabelles Kernel überprüft.
\<close>

(*find ./Downloads/Isabelle2022/src/HOL -name "*.thy"  | xargs grep axiomatiz | wc -l*)

subsection\<open>Deep Embedding vs. Shallow Embedding\<close>
text\<open>Im Bereich der mathematischen Modellierung wird oft
zwischen Deep Embedding und Shallow Embedding unterschieden.

Deep Embedding bedeutet, dass unsere domänenspezifische Logik komplett in der Meta-Logik
neu implementiert wird.
Die Meta-Logik wird von der domänenspezifischen Logik wegabstrahiert.
In Isabelle/HOL ist die Meta-Logik HOL.
Die domänenspezifische Logik ist unsere Logik mit der wir moralische Schlussfolgerungen
treffen wollen.
Wenn wir unsere "moralische Logik" komplett in HOL deep embedden wollen,
bedeutet dass, dass wir alle Konzepte unserer Logik komplett neu implementieren.
So könnten wir beispielsweise definieren:
\<^theory_text>\<open>datatype moralisch = Moralisch | NichtMoralisch\<close>.
Ein Deep Embedding hat den Vorteil, dass wir die Semantik unserer Logik komplett
selbst definieren können.
Wenn sich also HOL und unsere Logik verschieden verhalten sollen, ist ein Deep Embedding
unerlässlich.
Der Nachteil ist allerdings, dass wir alles was wir brauchen selbst definieren müssen
und die wir z.B. nicht von der enormen Menge an Lemmata der Isabelle Standardbibliothek
profitieren.

Im Gegensatz dazu steht ein Shallow Embedding.
Dabei wird die domänenspezifische Logik direkt in der Meta-Logik definiert.
Alle Konzepte der Meta-Logik werden übernommen.
Dies funktioniert nur, wenn sich die Meta-Logik so wie unsere domänenspezifische Logik verhält.
Die Abstraktionsebene die unsere domänenspezifische Logik über die Meta-Logik spannt
wird so dünn wie möglich gehalten und so viele Konzepte wie möglich der Meta-Logik
werden Eins-zu-Eins in der domänenspezifischen Logik übernommen.
Beispielsweise könnten wir uns entscheiden keinen neuen Datentyp \<^theory_text>\<open>datatype moralisch\<close> einzuführen.
Wir könnten einen bestehenden HOL Datentyp weiterverwenden,
beispielsweise \<^theory_text>\<open>type_synonym moralisch = bool\<close>.
Dies funktioniert nur, wenn sich der HOL-Typ \<^typ>\<open>bool\<close> tatsächlich so verhält,
wie wir es gerne für unseren domänenspezifischen "moralisch" Typen hätten.
Ein riesiger Vorteil ist, dass wir bei einem Shallow Embedding die gesamte
Isabelle/HOL Standardbibliothek an bestehenden Theories und Lemmata weiterverwenden können.
Beispielsweise sind alle Lemmata über \<^typ>\<open>bool\<close> automatisch für uns verfügbar
und bestehende Beweistaktiken funktionieren automatisch auf bestehenden HOL Typen.

Das Beispiel über \<^theory_text>\<open>datatype moralisch\<close> ist etwas übertrieben
und keine neuen Datentypen einzuführen und nur z.B. \<^theory_text>\<open>type_synonym moralisch = bool\<close>
zu verwenden ist natürlich etwas radikal.
Einem Shallow Embedding ist es nicht verboten neue Datentypen einzuführen
und eine eigene Semantik auf diesen Datentypen zu definieren.
Dennoch gilt der allgemeine Grundsatz für ein Shallow Embedding:
Die Meta-Logik wird so weit weiterverwendet wie möglich.

Wir versuchen in diesem Artikel wann immer möglich ein Shallow Embedding zu machen
und so viel von HOL und Isabelles Standardbibliothek weiterzuverwenden wie möglich.
\<close>

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_11
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun rev :: "'a list => 'a list" where
  "rev (nil2) = nil2"
| "rev (cons2 z xs) = x (rev xs) (cons2 z (nil2))"

theorem property0 :
  "((rev (x (rev y) (rev z))) = (x z y))"
  oops

end


theory IMP2_Binary_Heap
  imports IMP2.IMP2 IMP2.IMP2_Aux_Lemmas
begin
section \<open>Introduction\<close>
text \<open>In this submission imperative versions of the following array-based binary minimum heap
      functions are implemented and verified: insert, get-min, delete-min, make-heap.
      The latter three are then used to prove the correctness of an in-place heapsort, which sorts
      an array in descending order. To do that in Isabelle/HOL, the proof framework IMP2
      \cite{IMP2-AFP} is used. Here arrays are modeled by \<open>int \<Rightarrow> int\<close> functions. The imperative
      implementations are iterative versions of the partly recursive algorithms described in
      \cite{MS} and \cite{CLRS}.

      This submission starts with the basic definitions and lemmas, which are needed for array-based
      binary heaps. These definitions and lemmas are parameterised with an arbitrary (transitive)
      comparison function (where such a function is needed), so they are not only applicable to
      minimum heaps. After some more general, useful lemmas on arrays, the imperative minimum heap
      functions and the heapsort are implemented and verified.\<close>

section \<open>Heap Related Definitions and Theorems\<close>
subsection \<open>Array Bounds\<close>
text \<open>A small helper function is used to define valid array indices. Note that the lower index
      bound \<open>l\<close> is arbitrary and not fixed to 0 or 1. The upper index bound \<open>r\<close> is not a valid
      index itself, so that the empty array can be denoted by having \<open>l = r\<close>.\<close>
abbreviation bounded :: "int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  "bounded l r x \<equiv> l \<le> x \<and> x < r"

subsection \<open>Parent and Children\<close>

subsubsection \<open>Definitions\<close>
text \<open>For the notion of an array-based binary heap, the parent and child relations on the array
      indices need to be defined.\<close>
definition parent :: "int \<Rightarrow> int \<Rightarrow> int" where
  "parent l c = l + (c - l - 1) div 2"

definition l_child :: "int \<Rightarrow> int \<Rightarrow> int" where
  "l_child l p = 2 * p - l + 1"

definition r_child :: "int \<Rightarrow> int \<Rightarrow> int" where
  "r_child l p = 2 * p - l + 2"

subsubsection \<open>Lemmas\<close>
lemma parent_upper_bound: "parent l c < c \<longleftrightarrow> l \<le> c"
  unfolding parent_def by auto

lemma parent_upper_bound_alt: "l \<le> parent l c \<Longrightarrow> parent l c < c"
  unfolding parent_def by simp

lemma parent_lower_bound: "l \<le> parent l c \<longleftrightarrow> l < c"
  unfolding parent_def by linarith

lemma grand_parent_upper_bound: "parent l (parent l c) < c \<longleftrightarrow> l \<le> c"
  unfolding parent_def by linarith

corollary parent_bounds: "l < x \<Longrightarrow> x < r \<Longrightarrow> bounded l r (parent l x)"
  using parent_lower_bound parent_upper_bound_alt by fastforce

lemma l_child_lower_bound: " p < l_child l p \<longleftrightarrow> l \<le> p"
  unfolding l_child_def by simp

corollary l_child_lower_bound_alt: "l \<le> x \<Longrightarrow> x \<le> p \<Longrightarrow> x < l_child l p"
  using l_child_lower_bound[of p l] by linarith

lemma parent_l_child[simp]: "parent l (l_child l n) = n"
  unfolding parent_def l_child_def by simp

lemma r_child_lower_bound: "l \<le> p \<Longrightarrow> p < r_child l p"
  unfolding r_child_def by simp

corollary r_child_lower_bound_alt: "l \<le> x \<Longrightarrow> x \<le> p \<Longrightarrow> x < r_child l p"
  using r_child_lower_bound[of l p] by linarith

lemma parent_r_child[simp]: "parent l (r_child l n) = n"
  unfolding parent_def r_child_def by simp

lemma smaller_l_child: "l_child l x < r_child l x"
  unfolding l_child_def r_child_def by simp

lemma parent_two_children:
  "(c = l_child l p \<or> c = r_child l p) \<longleftrightarrow> parent l c = p"
  unfolding parent_def l_child_def r_child_def by linarith

subsection \<open>Heap Invariants\<close>
subsubsection \<open>Definitions\<close>
text \<open>The following heap invariants and the following lemmas are parameterised with an arbitrary
      (transitive) comparison function. For the concrete function implementations at the end of
      this submission \<open>\<le>\<close> on ints is used.\<close>

text \<open>For the \<open>make_heap\<close> function, which transforms an unordered array into a valid heap,
      the notion of a partial heap is needed. Here the heap invariant only holds for array indices
      between a certain valid array index \<open>m\<close> and \<open>r\<close>. The standard heap invariant is then
      simply the special case where \<open>m = l\<close>.\<close>
definition is_partial_heap
  :: "('a::order \<Rightarrow> 'a::order \<Rightarrow> bool) \<Rightarrow> (int \<Rightarrow> 'a::order) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  "is_partial_heap cmp heap l m r = (\<forall> x. bounded m r x \<longrightarrow>
               bounded m r (parent l x) \<longrightarrow> cmp (heap (parent l x)) (heap x))"

abbreviation is_heap
  :: "('a::order \<Rightarrow> 'a::order \<Rightarrow> bool) \<Rightarrow> (int \<Rightarrow> 'a::order) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  "is_heap cmp heap l r \<equiv> is_partial_heap cmp heap l l r"

text \<open>During all of the modifying heap functions the heap invariant is temporarily violated at
      a single index \<open>i\<close> and it is then gradually restored by either \<open>sift_down\<close> or
      \<open>sift_up\<close>. The following definitions formalize these weakened invariants.

      The second part of the conjunction in the following definitions states, that the comparison
      between the parent of \<open>i\<close> and each of the children of \<open>i\<close> evaluates to \<open>True\<close> without
      explicitly using the child relations.\<close>
definition is_partial_heap_except_down
  :: "('a::order \<Rightarrow> 'a::order \<Rightarrow> bool) \<Rightarrow> (int \<Rightarrow> 'a::order) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  "is_partial_heap_except_down cmp heap l m r i = (\<forall> x. bounded m r x \<longrightarrow>
    ((parent l x \<noteq> i \<longrightarrow> bounded m r (parent l x) \<longrightarrow> cmp (heap (parent l x)) (heap x)) \<and>
     (parent l x = i \<longrightarrow> bounded m r (parent l (parent l x))
                     \<longrightarrow> cmp (heap (parent l (parent l x))) (heap x))))"

abbreviation is_heap_except_down
  :: "('a::order \<Rightarrow> 'a::order \<Rightarrow> bool) \<Rightarrow> (int \<Rightarrow> 'a::order) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  "is_heap_except_down cmp heap l r i \<equiv> is_partial_heap_except_down cmp heap l l r i"

text \<open>As mentioned the notion of a partial heap is only needed for \<open>make_heap\<close>,
      which only uses \<open>sift_down\<close> internally, so there doesn't need to be an additional
      definition for the partial heap version of the \<open>sift_up\<close> invariant.\<close>
definition is_heap_except_up
  :: "('a::order \<Rightarrow> 'a::order \<Rightarrow> bool) \<Rightarrow> (int \<Rightarrow> 'a::order) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  "is_heap_except_up cmp heap l r i = (\<forall> x. bounded l r x \<longrightarrow>
    ((x \<noteq> i \<longrightarrow> bounded l r (parent l x) \<longrightarrow> cmp (heap (parent l x)) (heap x)) \<and>
     (parent l x = i \<longrightarrow> bounded l r (parent l (parent l x))
                     \<longrightarrow> cmp (heap (parent l (parent l x))) (heap x))))"

subsubsection \<open>Lemmas\<close>

lemma empty_partial_heap[simp]: "is_partial_heap cmp heap l r r"
  unfolding is_partial_heap_def by linarith

lemma is_partial_heap_smaller_back:
  "is_partial_heap cmp heap l m r \<Longrightarrow> r' \<le> r \<Longrightarrow> is_partial_heap cmp heap l m r'"
  unfolding is_partial_heap_def by simp

lemma is_partial_heap_smaller_front:
  "is_partial_heap cmp heap l m r \<Longrightarrow> m \<le> m' \<Longrightarrow> is_partial_heap cmp heap l m' r"
  unfolding is_partial_heap_def by simp

text \<open>The second half of each array is a is a partial binary heap, since it contains only leafs,
      which are all trivial binary heaps.\<close>
lemma snd_half_is_partial_heap:
  "(l + r) div 2 \<le> m \<Longrightarrow> is_partial_heap cmp heap l m r"
  unfolding is_partial_heap_def parent_def by linarith

lemma modify_outside_partial_heap:
  assumes
    "heap = heap' on {m..<r}"
    "is_partial_heap cmp heap l m r"
  shows "is_partial_heap cmp heap' l m r"
  using assms eq_onD unfolding is_partial_heap_def by fastforce

text \<open>The next few lemmas formalize how the heap invariant is weakened, when the heap is modified
      in a certain way.\<close>

text \<open>This lemma is used by \<open>make_heap\<close>.\<close>
lemma partial_heap_added_first_el:
  assumes
    "l \<le> m" "m \<le> r"
    "is_partial_heap cmp heap l (m + 1) r"
  shows "is_partial_heap_except_down cmp heap l m r m"
 unfolding is_partial_heap_except_down_def
proof
  fix x
  let ?p_x = "parent l x"
  let ?gp_x = "parent l ?p_x"
  show "bounded m r x \<longrightarrow>
        (?p_x \<noteq> m \<longrightarrow> bounded m r ?p_x \<longrightarrow> cmp (heap ?p_x) (heap x)) \<and>
        (?p_x = m \<longrightarrow> bounded m r ?gp_x \<longrightarrow> cmp (heap ?gp_x) (heap x))"
  proof
    assume x_bound: "bounded m r x"
    have p_x_lower: "?p_x \<noteq> m \<longrightarrow> bounded m r ?p_x \<longrightarrow> ?p_x \<ge> m + 1"
      by simp
    hence "?p_x \<noteq> m \<longrightarrow> bounded m r ?p_x \<longrightarrow> x \<ge> m + 1"
      using parent_upper_bound[of l x] x_bound assms(1) by linarith
    hence p_invariant: "(?p_x \<noteq> m \<longrightarrow> bounded m r ?p_x \<longrightarrow> cmp (heap ?p_x) (heap x))"
      using assms(3) is_partial_heap_def p_x_lower x_bound by blast

    have gp_up_bound: "(?p_x = m \<longrightarrow> ?gp_x < m)"
      by (simp add: assms(1) parent_upper_bound)
    show "(?p_x \<noteq> m \<longrightarrow> bounded m r ?p_x \<longrightarrow> cmp (heap ?p_x) (heap x)) \<and>
          (?p_x = m \<longrightarrow> bounded m r ?gp_x \<longrightarrow> cmp (heap ?gp_x) (heap x))"
      using gp_up_bound p_invariant by linarith
  qed
qed

text \<open>This lemma is used by \<open>del_min\<close>.\<close>
lemma heap_changed_first_el:
  assumes "is_heap cmp heap l r" "l \<le> r"
  shows "is_heap_except_down cmp (heap(l := b)) l r l"
proof -
  have "is_partial_heap cmp heap l (l + 1) r"
    using assms(1) is_partial_heap_smaller_front by fastforce
  hence "is_partial_heap cmp (heap(l := b)) l (l + 1) r"
    using modify_outside_partial_heap[of heap] by simp
  thus ?thesis
    by (simp add: assms(2) partial_heap_added_first_el)
qed

text \<open>This lemma is used by \<open>insert\<close>.\<close>

subsubsection \<open>First Heap Element\<close>
text \<open>The next step is to show that the first element of the heap is always the ``smallest''
      according to the given comparison function. For the proof a rule for strong induction on lower
      bounded integers is needed. Its proof is based on the proof of strong induction on natural
      numbers found in \cite{Str_Ind}.\<close>
lemma strong_int_gr_induct_helper:
  assumes "k < (i::int)" "(\<And>i. k < i \<Longrightarrow> (\<And>j. k < j \<Longrightarrow> j < i \<Longrightarrow> P j) \<Longrightarrow> P i)"
  shows "\<And>j. k < j \<Longrightarrow> j < i \<Longrightarrow> P j"
  using assms
proof(induction i rule: int_gr_induct)
  case base
  then show ?case by linarith
next
  case (step i)
  then show ?case
  proof(cases "j = i")
    case True
    then show ?thesis using step.IH step.prems(1,3) by blast
  next
    case False
    hence "j < i" using step.prems(2) by simp
    then show ?thesis using step.IH step.prems(1,3) by blast
  qed
qed

theorem strong_int_gr_induct:
  assumes
    "k < (i::int)"
    "(\<And>i. k < i \<Longrightarrow> (\<And>j. k < j \<Longrightarrow> j < i \<Longrightarrow> P j) \<Longrightarrow> P i)"
  shows "P i"
  using assms less_induct strong_int_gr_induct_helper by blast

text \<open>Now the main theorem, that the first heap element is the ``smallest'' according to the
      given comparison function, can be proven.\<close>
theorem heap_first_el:
  assumes
    "is_heap cmp heap l r"
    "transp cmp"
    "l < x" "x < r"
  shows "cmp (heap l) (heap x)"
  using assms unfolding is_partial_heap_def
proof(induction x rule: strong_int_gr_induct[of l])
  case 1
  then show ?case using assms(3) by simp
next
  case (2 i)
  have cmp_pi_i: "cmp (heap (parent l i)) (heap i)"
    using "2.hyps" "2.prems"(1,4) parent_bounds by simp
  then show ?case
  proof(cases)
    assume "parent l i > l"
    then have "cmp (heap l) (heap (parent l i))"
      using "2.IH" "2.prems"(1,2,4) parent_upper_bound_alt by simp
    then show ?thesis
      using "2.prems"(2) cmp_pi_i transpE by metis
  next
    assume "\<not> parent l i > l"
    then have "parent l i = l"
      using "2.hyps" dual_order.order_iff_strict parent_lower_bound by metis
    then show ?thesis
      using cmp_pi_i by simp
  qed
qed

section \<open>General Lemmas on Arrays\<close>
text \<open>Some additional lemmas on @{const "mset_ran"}, @{const "swap"} and @{const "eq_on"} are needed
      for the final proofs.\<close>

subsection \<open>Lemmas on @{const "mset_ran"}\<close>
abbreviation arr_mset :: "(int \<Rightarrow> 'a) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 'a multiset" where
  "arr_mset arr l r \<equiv> mset_ran arr {l..<r}"

lemma in_mset_imp_in_array:
  "x \<in># (arr_mset arr l r) \<longleftrightarrow> (\<exists>i. bounded l r i \<and> arr i = x)"
  unfolding mset_ran_def by fastforce

lemma arr_mset_remove_last:
  "l \<le> r \<Longrightarrow> arr_mset arr l r = arr_mset arr l (r + 1) - {#arr r#}"
  by (simp add: intvs_upper_decr mset_ran_def)

lemma arr_mset_append:
  "l \<le> r \<Longrightarrow> arr_mset arr l (r + 1) = arr_mset arr l r + {#arr r#}"
  using arr_mset_remove_last[of l r arr] by simp

corollary arr_mset_append_alt:
  "l \<le> r \<Longrightarrow> arr_mset (arr(r := b)) l (r + 1) = arr_mset arr l r + {#b#}"
  by (simp add: arr_mset_append mset_ran_subst_outside)

lemma arr_mset_remove_first:
  "i \<le> r \<Longrightarrow> arr_mset arr (i - 1) r = arr_mset arr i r + {#arr (i - 1)#}"
  by(induction r rule: int_ge_induct) (auto simp add: arr_mset_append)

lemma arr_mset_split:
  assumes "l \<le> m" "m \<le> r"
  shows "arr_mset arr l r = arr_mset arr l m + arr_mset arr m r"
  using assms
proof(induction m rule: int_ge_induct[of l])
  case (step i)
  have add_last: "arr_mset arr l (i + 1) = arr_mset arr l i + {#arr i#}"
    using step arr_mset_append by blast
  have rem_first: "arr_mset arr (i+1) r = arr_mset arr i r - {#arr i#}"
    by (metis step.prems arr_mset_remove_first add_diff_cancel_right')
  show ?case
    using step add_last rem_first by fastforce
qed (simp)

text \<open>That the first element in a heap is the ``smallest'', can now be expressed using multisets.\<close>
corollary heap_first_el_alt:
  assumes
    "transp cmp"
    "is_heap cmp heap l r"
    "x \<in># (arr_mset heap l r)"
    "heap l \<noteq> x"
  shows "cmp (heap l) x"
  by(metis assms heap_first_el in_mset_imp_in_array le_less)

subsection \<open>Lemmas on @{term "swap"} and @{term "eq_on"}\<close>

lemma eq_on_subset:
  "arr1 = arr2 on R \<Longrightarrow> S \<subseteq> R \<Longrightarrow> arr1 = arr2 on S"
  by (simp add: eq_on_def set_mp)

lemma swap_swaps:
  "arr' = swap arr x y \<Longrightarrow> arr' y = arr x \<and> arr' x = arr y"
  unfolding swap_def by simp

lemma swap_only_swaps:
  "arr' = swap arr x y \<Longrightarrow> z \<noteq> x \<Longrightarrow> z \<noteq> y \<Longrightarrow> arr' z = arr z"
  unfolding swap_def by simp

lemma swap_commute: "swap arr x y = swap arr y x"
  unfolding swap_def by fastforce

lemma swap_eq_on:
  "arr1 = arr2 on S \<Longrightarrow> x \<notin> S \<Longrightarrow> y \<notin> S \<Longrightarrow> arr1 = swap arr2 x y on S"
  unfolding swap_def by simp

corollary swap_parent_eq_on:
  assumes
    "arr1 = arr2 on - {l..<r}"
    "l < c" "c < r"
  shows "arr1 = swap arr2 (parent l c) c on - {l..<r} "
  using parent_bounds swap_eq_on assms by fastforce

corollary swap_child_eq_on:
  assumes
    "arr1 = arr2 on - {l..<r}"
    "c = l_child l p \<or> c = r_child l p"
    "l \<le> p" "c < r"
  shows "arr1 = swap arr2 p c on - {l..<r} "
  by (metis assms parent_lower_bound parent_two_children swap_parent_eq_on)

lemma swap_child_mset:
  assumes
    "arr_mset arr1 l r = arr_mset arr2 l r"
    "c = l_child l p \<or> c = r_child l p"
    "l \<le> p" "c < r"
  shows "arr_mset arr1 l r = arr_mset (swap arr2 p c) l r"
proof -
  have child_bounded: "l < c \<and> c < r"
    by (metis assms(2-4) parent_lower_bound parent_two_children)
  have parent_bounded: "bounded l r p"
    by (metis assms(2-4) dual_order.strict_trans parent_two_children parent_upper_bound_alt)
  thus ?thesis
    using assms(1) child_bounded mset_ran_swap[of p "{l..<r}" c arr2] atLeastLessThan_iff
    by simp
qed

text \<open>The following lemma shows, which propositions have to hold on the pre-swap array, so that
      a comparison between two elements holds on the post-swap array. This is useful for the
      proofs of the loop invariants of \<open>sift_up\<close> and \<open>sift_down\<close>. The lemma is kept
      quite general (except for the argument order) and could probably be more closely
      related to the parent relation for more concise proofs.\<close>
lemma cmp_swapI:
  fixes arr::"'a::order \<Rightarrow> 'a::order"
  assumes
    "m < n \<and> x < y"
    "m < n \<and> x < y \<Longrightarrow> x = m \<Longrightarrow> y = n \<Longrightarrow> P (arr n) (arr m)"
    "m < n \<and> x < y \<Longrightarrow> x \<noteq> m \<Longrightarrow> x \<noteq> n \<Longrightarrow> y \<noteq> m \<Longrightarrow> y \<noteq> n \<Longrightarrow> P (arr m) (arr n)"
    "m < n \<and> x < y \<Longrightarrow> x = m \<Longrightarrow> y \<noteq> m \<Longrightarrow> y \<noteq> n \<Longrightarrow>  P (arr y) (arr n)"
    "m < n \<and> x < y \<Longrightarrow> x = n \<Longrightarrow> y \<noteq> m \<Longrightarrow> y \<noteq> n \<Longrightarrow>  P (arr m) (arr y)"
    "m < n \<and> x < y \<Longrightarrow> x \<noteq> m \<Longrightarrow> x \<noteq> n \<Longrightarrow> y = n \<Longrightarrow> P (arr m) (arr x)"
    "m < n \<and> x < y \<Longrightarrow> x \<noteq> m \<Longrightarrow> x \<noteq> n \<Longrightarrow> y = m \<Longrightarrow> P (arr x) (arr n)"
  shows "P (swap arr x y m) (swap arr x y n)"
  by (metis assms order.asym swap_only_swaps swap_swaps)

section \<open>Imperative Heap Implementation\<close>
text \<open>The following imperative heap functions are based on \cite{MS} and \cite{CLRS}. All functions,
      that are recursive in these books, are iterative in the following implementations. The
      function definitions are done with IMP2 \cite{IMP2-AFP}. From now on the heaps only contain
      ints and only use \<open>\<le>\<close> as comparison function. The auxiliary lemmas used from now on are
      heavily modeled after the proof goals, that are generated by the vcg tool (also part of IMP2).\<close>

subsection \<open>Simple Functions\<close>
subsubsection \<open>Parent, Children and Swap\<close>
text \<open>In this section the parent and children relations are expressed as IMP2 procedures.
      Additionally a simple procedure, that swaps two array elements, is defined.\<close>
procedure_spec prnt (l, x) returns p
  assumes True
    ensures "p = parent l\<^sub>0 x\<^sub>0"
  defines \<open>p = ((x - l - 1) / 2 + l)\<close>
  by vcg (simp add: parent_def)

procedure_spec left_child (l, x) returns lc
  assumes True
    ensures "lc = l_child l\<^sub>0 x\<^sub>0"
  defines \<open>lc = 2 * x - l + 1\<close>
  by vcg (simp add: l_child_def)

procedure_spec right_child (l, x) returns rc
  assumes True
    ensures "rc = r_child l\<^sub>0 x\<^sub>0"
  defines \<open>rc = 2 * x - l + 2\<close>
  by vcg (simp add: r_child_def)

procedure_spec swp (heap, x, y) returns heap
  assumes True
    ensures "heap = swap heap\<^sub>0 x\<^sub>0 y\<^sub>0 "
  defines \<open>tmp = heap[x]; heap[x] = heap[y]; heap[y] = tmp\<close>
  by vcg (simp add: swap_def)

subsubsection \<open>\<open>get_min\<close>\<close>
text \<open>In this section \<open>get_min\<close> is defined, which simply returns the first element (the minimum) of
      the heap. For this definition an additional theorem is proven, which enables the use of
      @{const "Min_mset"} in the postcondition.\<close>

theorem heap_minimum:
  assumes
    "l < r"
    "is_heap (\<le>) heap l r"
  shows "heap l = Min_mset (arr_mset heap l r)"
proof -
  have "(\<forall>x \<in># (arr_mset heap l r). (heap l) \<le> x)"
    using assms(2) heap_first_el_alt transp_le by blast
  thus ?thesis
    by (simp add: assms(1) dual_order.antisym)
qed

procedure_spec get_min (heap, l, r) returns min
  assumes "l < r \<and> is_heap (\<le>) heap l r"
    ensures "min = Min_mset (arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0)"
  for heap[] l r
  defines \<open>min = heap[l]\<close>
  by vcg (simp add: heap_minimum)

subsection \<open>Modifying Functions\<close>

subsubsection \<open>\<open>sift_up\<close> and \<open>insert\<close>\<close>
text \<open>The next heap function is \<open>insert\<close>, which internally uses \<open>sift_up\<close>. In the beginning of
      this section \<open>sift_up_step\<close> is proven, which states that each \<open>sift_up\<close> loop iteration
      correctly transforms the weakened heap invariant. For its proof two additional
      auxiliary lemmas are used. After \<open>sift_up_step\<close> \<open>sift_up\<close> and then \<open>insert\<close> are verified.\<close>

text \<open>\<open>sift_up_step\<close> can be proven directly by the smt-solver without auxiliary lemmas, but they
      were introduced to show the proof details. The analogous proofs for \<open>sift_down\<close> were
      just solved with smt, since the proof structure should be very similar, even though the
      \<open>sift_down\<close> proof goals are slightly more complex.\<close>
lemma sift_up_step_aux1:
  fixes heap::"int \<Rightarrow> int"
  assumes
    "is_heap_except_up (\<le>) heap l r x"
    "parent l x \<ge> l"
    "(heap x) \<le> (heap (parent l x))"
    "bounded l r k"
    "k \<noteq> (parent l x)"
    "bounded l r (parent l k)"
  shows "(swap heap (parent l x) x (parent l k)) \<le> (swap heap (parent l x) x k)"
  apply(intro cmp_swapI[of "(parent l k)" k "(parent l x)" x "(\<le>)" heap])
  subgoal using assms(2,6) parent_upper_bound_alt by blast
  subgoal using assms(3) by blast
  subgoal using assms(1,4,6) unfolding is_heap_except_up_def by blast
  subgoal using assms(1,3,4,6) unfolding is_heap_except_up_def by fastforce
  subgoal using assms(5) by blast
  subgoal by blast
  subgoal using assms(1,2,4) unfolding is_heap_except_up_def by simp
  done

lemma sift_up_step_aux2:
  fixes heap::"int \<Rightarrow> int"
  assumes
    "is_heap_except_up (\<le>) heap l r x"
    "parent l x \<ge> l"
    "heap x \<le> (heap (parent l x))"
    "bounded l r k"
    "parent l k = parent l x"
    "bounded l r (parent l (parent l k))"
  shows
    "swap heap (parent l x) x (parent l (parent l k)) \<le> swap heap (parent l x) x k"
  using assms unfolding is_heap_except_up_def
proof-
  let ?gp_k = "parent l (parent l k)"
  let ?gp_x = "parent l (parent l x)"
  have gp_k_eq_gp_x: "swap heap (parent l x) x ?gp_k = heap ?gp_x"
    by (metis assms(2,5) grand_parent_upper_bound less_irrefl swap_only_swaps)
  show ?thesis
      using assms unfolding is_heap_except_up_def
  proof(cases)
    assume k_eq_x: "k = x"
    have "swap heap (parent l x) x k = heap (parent l x)"
      by (metis k_eq_x swap_swaps)
    then show ?thesis
      using assms(1,2,4,6) unfolding is_heap_except_up_def
      by (metis gp_k_eq_gp_x k_eq_x parent_bounds parent_lower_bound)
  next
    assume k_neq_x: "k \<noteq> x"
    have "swap heap (parent l x) x k = heap k"
      by (metis assms(5) gp_k_eq_gp_x k_neq_x swap_only_swaps)
    then show ?thesis using assms unfolding is_heap_except_up_def
      by (metis gp_k_eq_gp_x k_neq_x order_trans parent_bounds parent_lower_bound)
  qed
qed

lemma sift_up_step:
  fixes heap::"int \<Rightarrow> int"
  assumes
    "is_heap_except_up (\<le>) heap l r x"
    "parent l x \<ge> l"
    "(heap x) \<le> (heap (parent l x))"
  shows "is_heap_except_up (\<le>) (swap heap (parent l x) x) l r (parent l x)"
  using assms sift_up_step_aux1 sift_up_step_aux2
  unfolding is_heap_except_up_def by blast

text \<open>\<open>sift_up\<close> restores the heap invariant, that is only violated at the current position, by
      iteratively swapping the current element with its parent until the beginning of the array is
      reached or the current element is bigger than its parent.\<close>
procedure_spec sift_up (heap, l, r, x) returns heap
  assumes "is_heap_except_up (\<le>) heap l r x \<and> bounded l r x"
    ensures "is_heap (\<le>) heap l\<^sub>0 r\<^sub>0 \<and>
             arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0 = arr_mset heap l\<^sub>0 r\<^sub>0 \<and>
             heap\<^sub>0 = heap on - {l\<^sub>0..<r\<^sub>0}"
  for heap[] l x r
  defines \<open>
    p = prnt(l, x);
    while (x > l \<and> heap[x] \<le> heap[p])
      @variant \<open>x - l\<close>
      @invariant \<open>is_heap_except_up (\<le>) heap l r x \<and> p = parent l x \<and>
                  bounded l r x \<and> arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0 = arr_mset heap l r \<and>
                  heap\<^sub>0 = heap  on - {l..<r}\<close>
    {
        heap = swp(heap, p, x);
        x = p;
        p = prnt(l, x)
    }\<close>
  apply vcg_cs
  apply(intro conjI)
  subgoal using parent_lower_bound sift_up_step by blast
  subgoal using parent_lower_bound by blast
  subgoal using parent_bounds by blast
  subgoal using parent_bounds by (simp add: mset_ran_swap)
  subgoal using swap_parent_eq_on by blast
  subgoal using parent_upper_bound by simp
  subgoal unfolding is_heap_except_up_def is_partial_heap_def
    by (metis le_less not_less parent_lower_bound)
  done

text \<open>\<open>insert\<close> inserts an element into a heap by appending it to the heap and restoring the heap
      invariant with @{const "sift_up"}.\<close>
procedure_spec insert (heap, l, r, el) returns (heap, l, r)
  assumes "is_heap (\<le>) heap l r \<and> l \<le> r"
    ensures "is_heap (\<le>) heap l r \<and>
             arr_mset heap l r = arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0 + {#el\<^sub>0#} \<and>
             l = l\<^sub>0 \<and> r = r\<^sub>0 + 1  \<and> heap\<^sub>0 = heap on - {l..<r}"
  for heap l r el
  defines \<open>
    heap[r] = el;
    x = r;
    r = r + 1;
    heap = sift_up(heap, l, r, x)
  \<close>
  apply vcg_cs
  subgoal by (simp add: heap_appended_el)
  subgoal by (metis arr_mset_append_alt add_mset_add_single)
  done

subsubsection \<open>\<open>sift_down\<close>, \<open>del_min\<close> and \<open>make_heap\<close>\<close>
text \<open>The next heap functions are \<open>del_min\<close> and \<open>make_heap\<close>, which both use \<open>sift_down\<close> to
      restore/establish the heap invariant. \<open>sift_down\<close> is proven first (this time without
      additional auxiliary lemmas) followed by \<open>del_min\<close> and \<open>make_heap\<close>.\<close>

text \<open>\<open>sift_down\<close> restores the heap invariant, that is only violated at the current position, by
      iteratively swapping the current element with its smallest child until the end of
      the array is reached or the current element is smaller than its children.\<close>
procedure_spec sift_down(heap, l, r, x) returns heap
  assumes "is_partial_heap_except_down (\<le>) heap l x r x \<and> l \<le> x \<and> x \<le> r"
    ensures "is_partial_heap (\<le>) heap l\<^sub>0 x\<^sub>0 r\<^sub>0 \<and>
             arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0 = arr_mset heap l\<^sub>0 r\<^sub>0 \<and>
             heap\<^sub>0 = heap on - {l\<^sub>0..<r\<^sub>0}"
  defines \<open>
   lc = left_child(l, x);
   rc = right_child(l, x);
    while (lc < r \<and> (heap[lc] < heap[x] \<or> (rc < r \<and> heap[rc] < heap[x])))
      @variant \<open>r - x\<close>
      @invariant \<open>is_partial_heap_except_down (\<le>) heap l x\<^sub>0 r x \<and>
                  x\<^sub>0 \<le> x \<and> x \<le> r \<and> lc = l_child l x \<and> rc = r_child l x \<and>
                  arr_mset heap\<^sub>0 l r = arr_mset heap l r \<and>
                  heap\<^sub>0 = heap on - {l..<r}\<close>
  {
    smallest = lc;
    if (rc < r \<and> heap[rc] < heap[lc]) {
      smallest = rc
    };
    heap = swp(heap, x, smallest);
    x = smallest;
    lc = left_child(l, x);
    rc = right_child(l, x)
  }\<close>
  apply vcg_cs
  subgoal
    apply(intro conjI)
    subgoal unfolding is_partial_heap_except_down_def
      by (smt parent_two_children swap_swaps swap_only_swaps
          swap_commute parent_upper_bound_alt)
    subgoal using r_child_lower_bound_alt by fastforce
    subgoal using swap_child_mset order_trans by blast
    subgoal using swap_child_eq_on by fastforce
    done
  subgoal
    by (meson less_le_trans not_le order.asym r_child_lower_bound)
  subgoal
    apply(intro conjI)
    subgoal unfolding is_partial_heap_except_down_def
      by (smt parent_two_children swap_swaps swap_only_swaps
          swap_commute parent_upper_bound_alt)
    subgoal using l_child_lower_bound_alt by fastforce
    subgoal using swap_child_mset order_trans by blast
    subgoal using swap_child_eq_on by fastforce
    done
  subgoal
    by (meson less_le_trans not_le order.asym l_child_lower_bound)
  subgoal unfolding is_partial_heap_except_down_def is_partial_heap_def
    by (metis dual_order.strict_trans not_less parent_two_children smaller_l_child)
  done

text \<open>\<open>del_min\<close> needs an additional lemma which shows, that it actually removes (only) the minimum
      from the heap.\<close>
lemma del_min_mset:
  fixes heap::"int \<Rightarrow> int"
  assumes
    "l < r"
    "is_heap (\<le>) heap l r"
    "mod_heap = heap(l := heap (r - 1))"
    "arr_mset mod_heap l (r - 1) = arr_mset new_heap l (r - 1)"
  shows
    "arr_mset new_heap l (r - 1) = arr_mset heap l r - {#Min_mset (arr_mset heap l r)#}"
proof -
  let ?heap_mset = "arr_mset heap l r"
  have l_is_min: "heap l = Min_mset ?heap_mset"
    using assms(1,2) heap_minimum by blast
  have "(arr_mset mod_heap l r) = ?heap_mset + {#heap (r-1)#} - {#heap l#}"
    by (simp add: assms(1,3) mset_ran_subst_inside)
  hence "(arr_mset mod_heap l (r - 1)) = ?heap_mset - {#heap l#}"
    by (simp add: assms(1,3) arr_mset_remove_last)
  thus ?thesis
    using assms(4) l_is_min by simp
qed

text \<open>\<open>del_min\<close> removes the minimum element from the heap by replacing the first element with the
      last element, shrinking the array by one and subsequently restoring the heap invariant
      with @{const "sift_down"}.\<close>
procedure_spec del_min (heap, l, r) returns (heap, l, r)
  assumes "l < r \<and> is_heap (\<le>) heap l r"
    ensures "is_heap (\<le>) heap l r \<and>
             arr_mset heap l r = arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0 - {#Min_mset (arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0)#} \<and>
             l = l\<^sub>0 \<and> r = r\<^sub>0 - 1 \<and>
             heap\<^sub>0 = heap on - {l\<^sub>0..<r\<^sub>0}"
  for heap l r
  defines \<open>
    r = r - 1;
    heap[l] = heap[r];
    heap = sift_down(heap, l, r, l)
  \<close>
  apply vcg_cs
  subgoal by (simp add: heap_changed_first_el is_partial_heap_smaller_back)
  subgoal
    apply(rule conjI)
    subgoal using del_min_mset by blast
    subgoal by (simp add: eq_on_def intvs_incdec(3) intvs_lower_incr)
    done
  done

text \<open>\<open>make_heap\<close> transforms an arbitrary array into a heap by iterating through all array
      positions from the middle of the array up to the beginning of the array and calling
      @{const "sift_down"} for each one.\<close>
procedure_spec make_heap (heap, l, r) returns heap
  assumes "l \<le> r"
    ensures "is_heap (\<le>) heap l\<^sub>0 r\<^sub>0 \<and>
             arr_mset heap l\<^sub>0 r\<^sub>0 = arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0 \<and>
             heap\<^sub>0 = heap on - {l\<^sub>0..< r\<^sub>0}"
  for heap[] l r
  defines \<open>
    y = (r + l)/2 - 1;
    while (y \<ge> l)
          @variant \<open>y - l + 1\<close>
          @invariant \<open>is_partial_heap (\<le>) heap l (y + 1) r \<and>
                      arr_mset heap l r = arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0 \<and>
                      l - 1 \<le> y \<and> y < r \<and> heap\<^sub>0 = heap on - {l..<r}\<close>
    {
      heap = sift_down(heap, l, r, y);
      y = y - 1
    }\<close>
  apply(vcg_cs)
  subgoal
    apply(rule conjI)
    subgoal by (simp add: snd_half_is_partial_heap add.commute)
    subgoal by linarith
    done
  subgoal using partial_heap_added_first_el le_less by blast
  subgoal using eq_on_trans by blast
  subgoal using dual_order.antisym by fastforce
  done

subsection \<open>Heapsort Implementation\<close>

text \<open>The final part of this submission is the implementation of the in-place heapsort. Firstly it
      builds the \<open>\<le>\<close>-heap and then it iteratively removes the minimum of the heap, which is put at
      the now vacant end of the shrinking heap. This is done until the heap is empty, which leaves
      the array sorted in descending order.\<close>
subsubsection \<open>Auxiliary Lemmas\<close>
text \<open>Firstly the notion of a sorted array is needed. This is more or less the same as
      @{const "ran_sorted"} generalized for arbitrary comparison functions.\<close>
definition array_is_sorted :: "(int \<Rightarrow> int \<Rightarrow> bool) \<Rightarrow>  (int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  "array_is_sorted cmp a l r \<equiv> \<forall>i. \<forall>j. bounded l r i \<longrightarrow> bounded l r j \<longrightarrow> i < j \<longrightarrow> cmp (a i) (a j)"

text \<open>This lemma states, that the heapsort doesn't change the elements contained in the array during
      the loop iterations.\<close>
lemma heap_sort_mset_step:
  fixes arr::"int \<Rightarrow> int"
  assumes
    "l < m" "m \<le> r"
    "arr_mset arr' l (m - 1) = arr_mset arr l m - {#Min_mset (arr_mset arr l m)#}"
    "arr = arr' on - {l..<m}"
    "mod_arr = arr'(m - 1 := Min_mset (arr_mset arr l m))"
  shows "arr_mset arr l r = arr_mset mod_arr l r"
proof -
  let ?min = "{#Min_mset (arr_mset arr l m)#}"
  let ?new_arr_mset = "arr_mset mod_arr"
  have middle: "?new_arr_mset (m - 1) m = ?min"
    by (simp add: assms(5))
  have first_half: "?new_arr_mset l (m - 1) = arr_mset arr l m - ?min"
    by (simp add: assms(3,5) mset_ran_subst_outside)
  hence "?new_arr_mset l m = ?new_arr_mset l (m - 1) + ?new_arr_mset (m - 1) m"
    by (metis assms(1,3,5) diff_add_cancel middle arr_mset_append_alt zle_diff1_eq)
  hence first_half_middle: "?new_arr_mset l m = arr_mset arr l m"
    using middle first_half assms(1) by simp

  hence "mod_arr = arr on - {l..<m}"
    using assms(1,4,5) eq_on_sym eq_on_trans by auto
  then have second_half: "arr_mset arr m r = arr_mset mod_arr m r"
    by (simp add: eq_on_def mset_ran_cong)

  then show ?thesis
    by (metis arr_mset_split assms(1,2) first_half_middle le_less)
qed

text \<open>This lemma states, that each loop iteration leaves the growing second half of the array
      sorted in descending order.\<close>
lemma heap_sort_second_half_sorted_step:
  fixes arr::"int \<Rightarrow> int"
  assumes
    "l\<^sub>0 < m" "m \<le> r\<^sub>0"
    "arr = arr' on - {l\<^sub>0..<m}"
    "\<forall>i. \<forall>j. bounded m r\<^sub>0 i \<longrightarrow> bounded m r\<^sub>0 j \<longrightarrow>  i < j \<longrightarrow> arr j \<le> arr i"
    "\<forall>x\<in>#arr_mset arr l\<^sub>0 m. \<forall>y\<in>#arr_mset arr m r\<^sub>0. \<not> x < y"
    "bounded (m - 1) r\<^sub>0 i"
    "bounded (m - 1) r\<^sub>0 j"
    "i < j"
    "mod_arr = (arr'(m - 1 := Min_mset (arr_mset arr l\<^sub>0 m)))"
  shows "mod_arr j \<le> mod_arr i"
proof -
  have second_half_eq: "mod_arr = arr on {m..< r\<^sub>0}"
    using assms(3, 9) unfolding eq_on_def by simp
  have j_stricter_bound: "bounded m r\<^sub>0 j"
    using assms(6-8) by simp
  then have el_at_j: "mod_arr j \<in># arr_mset arr m r\<^sub>0"
    using eq_onD second_half_eq by fastforce
  then show ?thesis
  proof(cases)
    assume "i = (m-1)"
    then have "mod_arr i \<in># arr_mset arr l\<^sub>0 m"
      by (simp add: assms(1, 9))
    then show ?thesis
      using assms(5) el_at_j not_less by blast
  next
    assume "i \<noteq> (m-1)"
    then have "bounded m r\<^sub>0 i"
      using assms(6) by simp
    then show ?thesis
      using assms(4, 8) eq_on_def j_stricter_bound second_half_eq by force
  qed
qed

text \<open>The following lemma shows that all elements in the first part of the array (the binary heap)
      are bigger than the elements in the second part (the sorted part) after every iteration. This
      lemma and the invariant of the \<open>heap_sort\<close> loop use \<open>\<not> x < y\<close> instead of \<open>x \<ge> y\<close> since
      \<open>vcg_cs\<close> doesn't terminate in the latter case.\<close>
lemma heap_sort_fst_part_bigger_snd_part_step:
  fixes arr::"int \<Rightarrow> int"
  assumes
    "l\<^sub>0 < m"
    "m \<le> r\<^sub>0"
    "arr_mset arr' l\<^sub>0 (m - 1) = arr_mset arr l\<^sub>0 m - {#Min_mset (arr_mset arr l\<^sub>0 m)#}"
    "arr = arr' on - {l\<^sub>0..<m}"
    "\<forall>x\<in>#arr_mset arr l\<^sub>0 m. \<forall>y\<in>#arr_mset arr m r\<^sub>0. \<not> x < y"
    "mod_arr = arr'(m - 1 := Min_mset (arr_mset arr l\<^sub>0 m))"
    "x\<in>#arr_mset mod_arr l\<^sub>0 (m - 1)"
    "y\<in>#arr_mset mod_arr (m - 1) r\<^sub>0"
  shows "\<not> x < y"
proof -
  have "{m..<r\<^sub>0} \<subseteq> - {l\<^sub>0..<m}"
    by auto
  hence "arr' = arr on {m..<r\<^sub>0}"
    using assms(4) eq_on_sym eq_on_subset by blast
  hence arr_eq_on: "mod_arr = arr on {m..<r\<^sub>0}"
    by (simp add: assms(6))
  hence same_mset: "arr_mset mod_arr m r\<^sub>0 = arr_mset arr m r\<^sub>0"
    using mset_ran_cong by blast
  have "x \<in># arr_mset arr l\<^sub>0 m" using same_mset assms
    by (metis assms(3,6,7) add_mset_remove_trivial_eq lran_upd_outside(2)
        mset_lran cancel_ab_semigroup_add_class.diff_right_commute
        diff_single_trivial multi_self_add_other_not_self order_refl)
  then have x_bigger_min: "x \<ge> Min_mset (arr_mset arr l\<^sub>0 m)"
    using Min_le by blast
  have y_smaller_min: "y \<le> Min_mset (arr_mset arr l\<^sub>0 m)"
  proof(cases "y = mod_arr (m - 1)")
    case False
    hence "y\<in>#arr_mset mod_arr (m - 1) r\<^sub>0 - {#mod_arr (m - 1)#}"
      by (metis assms(8) diff_single_trivial insert_DiffM insert_noteq_member)
    then have "y\<in>#arr_mset arr m r\<^sub>0"
      by (simp add: assms(2) intvs_decr_l mset_ran_insert same_mset)
    then show ?thesis
      using assms(1) assms(5) by fastforce
  qed (simp add: assms(6))
  then show ?thesis
    using x_bigger_min by linarith
qed

subsubsection \<open>Implementation\<close>
text \<open>Now finally the correctness of the \<open>heap_sort\<close> is shown. As mentioned, it starts by
      transforming the array into a minimum heap using @{const "make_heap"}. Then in each
      iteration it removes the first element from the heap with @{const "del_min"} after its value
      was retrieved with @{const "get_min"}. This value is then put at the position freed by
      @{const "del_min"}.\<close>
program_spec heap_sort
  assumes "l \<le> r"
    ensures "array_is_sorted (\<ge>) arr l\<^sub>0 r\<^sub>0 \<and>
             arr_mset arr\<^sub>0 l\<^sub>0 r\<^sub>0 = arr_mset arr l\<^sub>0 r\<^sub>0 \<and>
             arr\<^sub>0 = arr on - {l\<^sub>0 ..<r\<^sub>0 } \<and> l = l\<^sub>0 \<and> r = r\<^sub>0"
  for l r arr[]
  defines \<open>
    arr = make_heap(arr, l, r);
    m = r;
    while (m > l)
      @variant \<open>m - l + 1\<close>
      @invariant \<open>is_heap (\<le>) arr l m \<and>
        array_is_sorted (\<ge>) arr m r\<^sub>0 \<and>
        (\<forall>x \<in># arr_mset arr l\<^sub>0 m. \<forall>y \<in># arr_mset arr m r\<^sub>0. \<not> x < y) \<and>
        arr_mset arr\<^sub>0 l\<^sub>0 r\<^sub>0 = arr_mset arr l\<^sub>0 r\<^sub>0 \<and>
        l \<le> m \<and> m \<le> r\<^sub>0 \<and> l = l\<^sub>0 \<and> arr\<^sub>0 = arr on - {l\<^sub>0 ..<r\<^sub>0}\<close>
    {
      min = get_min(arr, l, m);
      (arr, l, m) = del_min(arr, l, m);
      arr[m] = min
    }
  \<close>
  apply vcg_cs
  subgoal unfolding array_is_sorted_def by simp
  subgoal
    apply(intro conjI)
    subgoal unfolding is_partial_heap_def by simp
    subgoal unfolding array_is_sorted_def using heap_sort_second_half_sorted_step
      by blast
    subgoal using heap_sort_fst_part_bigger_snd_part_step by blast
    subgoal using heap_sort_mset_step by blast
    subgoal unfolding eq_on_def
      by (metis ComplD ComplI atLeastLessThan_iff less_le_trans)
    done
  done
end


theory Submission
  imports Defs
begin

lemma N_pos: "\<exists>m. N = Suc m"
  using proc_0
  by (cases N) (auto simp: Proc_def)

lemma reach_aux: "reachable st \<Longrightarrow> (\<forall>i. Proc i \<longrightarrow> pc st i \<noteq> assign_x \<longrightarrow> x st i = 1)"
  by (induction st rule: reachable.induct)
     (auto simp: update_x_def update_pc_def update_y_def)

theorem reachable_safe: "reachable st \<Longrightarrow> safe st"
proof (induction st rule: reachable.induct)
  case (init init_x init_y)
  then show ?case
    using proc_0
    by (auto simp: safe_def)
next
  case (x_step st i)
  then show ?case
    by (auto simp: safe_def update_x_def update_pc_def)
next
  case (y_step st i)
  show ?case
  proof (cases "Proc i")
    case True
    define j where "j = (i + 1) mod N"
    show ?thesis
      unfolding safe_def j_def[symmetric]
    proof (rule impI)
      assume assm: "\<forall>k. Proc k \<longrightarrow> pc (update_y (update_pc st i finished) i (x st j)) k = finished"
      obtain m where m_def: "N = Suc m"
        using N_pos
        by auto
      have proc_j: "Proc j"
        by (auto simp: j_def m_def Proc_def)
      have pc_j: "pc st j \<noteq> assign_x"
        using assm proc_j y_step(2)
        by (auto simp: update_y_def update_pc_def split: if_splits)
      have x_j: "x st j = 1"
        using reach_aux[OF y_step(1)] proc_j pc_j
        by auto
      show "\<exists>k. Proc k \<and> y (update_y (update_pc st i finished) i (x st j)) k = 1"
        using x_j True
        unfolding update_y_def update_pc_def
        by (auto simp: j_def)
    qed
  next
    case False
    then show ?thesis
      using y_step
      by (auto simp: safe_def update_y_def update_pc_def)
  qed
qed

end


theory utp_des_core
  imports UTP2.utp_wlp
begin

alphabet des_vars =
  ok :: bool

type_synonym ('s\<^sub>1, 's\<^sub>2) des_rel = "('s\<^sub>1 des_vars_scheme, 's\<^sub>2 des_vars_scheme) urel"
type_synonym ('s\<^sub>1) des_hrel = "('s\<^sub>1, 's\<^sub>1) des_rel"

notation des_vars.more\<^sub>L ("\<^bold>v\<^sub>D")

syntax
  "_svid_des_alpha"  :: "svid" ("\<^bold>v\<^sub>D")

translations
  "_svid_des_alpha" => "CONST des_vars.more\<^sub>L"

text \<open> The following notations define liftings from non-design predicates into design
  predicates using alphabet extensions. \<close>

abbreviation lift_desr ("\<lceil>_\<rceil>\<^sub>D")
where "\<lceil>P\<rceil>\<^sub>D \<equiv> P \<up> (\<^bold>v\<^sub>D \<times> \<^bold>v\<^sub>D)"

expr_ctr lift_desr

abbreviation lift_pre_desr ("\<lceil>_\<rceil>\<^sub>D\<^sub><")
where "\<lceil>p\<rceil>\<^sub>D\<^sub>< \<equiv> \<lceil>p\<^sup><\<rceil>\<^sub>D"

expr_ctr lift_pre_desr

abbreviation lift_post_desr ("\<lceil>_\<rceil>\<^sub>D\<^sub>>")
where "\<lceil>p\<rceil>\<^sub>D\<^sub>> \<equiv> \<lceil>p\<^sup>>\<rceil>\<^sub>D"

abbreviation drop_desr ("\<lfloor>_\<rfloor>\<^sub>D")
where "\<lfloor>P\<rfloor>\<^sub>D \<equiv> P \<down> (\<^bold>v\<^sub>D \<times> \<^bold>v\<^sub>D)"

abbreviation dcond :: "('\<alpha>, '\<beta>) des_rel \<Rightarrow> '\<alpha> pred \<Rightarrow> ('\<alpha>, '\<beta>) des_rel \<Rightarrow> ('\<alpha>, '\<beta>) des_rel"
where "dcond P b Q \<equiv> P \<triangleleft> \<lceil>b\<rceil>\<^sub>D\<^sub>< \<triangleright> Q"

syntax "_dcond" :: "logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("(3_ \<triangleleft> _ \<triangleright>\<^sub>D/ _)" [52,0,53] 52)
translations "_dcond P b Q" == "CONST dcond P (b)\<^sub>e Q"

definition design where
[pred]: "design P Q = ((ok\<^sup>< \<and> P) \<longrightarrow> (ok\<^sup>> \<and> Q))\<^sub>e"

definition rdesign :: "('s\<^sub>1, 's\<^sub>2) urel \<Rightarrow> ('s\<^sub>1, 's\<^sub>2) urel \<Rightarrow> ('s\<^sub>1, 's\<^sub>2) des_rel" where
[pred]: "rdesign P Q = design (P \<up> more\<^sub>L\<^sup>2) (Q \<up> more\<^sub>L\<^sup>2)"

syntax
  "_design"  :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infix "\<turnstile>" 85)
  "_rdesign" :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infix "\<turnstile>\<^sub>r" 85)
  "_ndesign" :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infix "\<turnstile>\<^sub>n" 85)

translations
  "P \<turnstile> Q" == "CONST design P Q"
  "P \<turnstile>\<^sub>r Q" == "CONST rdesign P Q"
  "p \<turnstile>\<^sub>n Q" == "(p\<^sup><)\<^sub>e \<turnstile>\<^sub>r Q"

syntax
  "_svid_des_alpha"  :: "svid" ("\<^bold>v\<^sub>D")

translations
  "_svid_des_alpha" => "CONST des_vars.more\<^sub>L"

lemma "false \<turnstile> true = true"
  by pred_auto

lemma "true \<turnstile> false = (\<not> $ok\<^sup><)\<^sub>e"
  by pred_auto

lemma design_union: "((P\<^sub>1 \<turnstile> Q\<^sub>1) \<or> (P\<^sub>2 \<turnstile> Q\<^sub>2)) = ((P\<^sub>1 \<and> P\<^sub>2) \<turnstile> (Q\<^sub>1 \<or> Q\<^sub>2))"
  by pred_auto

lemma design_cond: "(P\<^sub>1 \<turnstile> Q\<^sub>1) \<lhd> b \<rhd> (P\<^sub>2 \<turnstile> Q\<^sub>2) = (P\<^sub>1 \<lhd> b \<rhd> P\<^sub>2) \<turnstile> (Q\<^sub>1 \<lhd> b \<rhd> Q\<^sub>2)"
  by pred_auto

definition skip_d :: "('\<alpha>,'\<alpha>) des_rel" ("II\<^sub>D") where
  [pred]: "II\<^sub>D \<equiv> (true \<turnstile>\<^sub>r II)"

expr_ctr skip_d

definition bot_d :: "('\<alpha>, '\<beta>) des_rel" ("\<bottom>\<^sub>D") where
  [pred]: "\<bottom>\<^sub>D = (false \<turnstile> false)"

expr_ctr bot_d

definition top_d :: "('\<alpha>, '\<beta>) des_rel" ("\<top>\<^sub>D") where
  [pred]: "\<top>\<^sub>D = (true \<turnstile> false)"

expr_ctr top_d

lemma top_d_not_ok:
  "\<top>\<^sub>D = (\<not> ok\<^sup><)\<^sub>e"
  unfolding top_d_def design_def
  by (expr_simp, simp add: false_pred_def true_pred_def)

definition pre_design :: "('\<alpha>, '\<beta>) des_rel \<Rightarrow> ('\<alpha>, '\<beta>) urel" ("pre\<^sub>D") where
  [pred]: "pre\<^sub>D(P) =  (\<not>P\<lbrakk>True,False/ok\<^sup><,ok\<^sup>>\<rbrakk>) \<down> more\<^sub>L\<^sup>2"

expr_ctr pre_design

definition post_design :: "('\<alpha>, '\<beta>) des_rel \<Rightarrow> ('\<alpha>, '\<beta>) urel" ("post\<^sub>D") where
  [pred]: "post\<^sub>D(P) = P\<lbrakk>True,True/ok\<^sup><,ok\<^sup>>\<rbrakk> \<down> more\<^sub>L\<^sup>2"

expr_ctr post_design

syntax
  "_ok_f"  :: "logic \<Rightarrow> logic" ("_\<^sup>f" [1000] 1000)
  "_ok_t"  :: "logic \<Rightarrow> logic" ("_\<^sup>t" [1000] 1000)

translations
  "P\<^sup>f" \<rightharpoonup> "_subst P (CONST False) (_svid_post (CONST ok))"
  "P\<^sup>t" \<rightharpoonup> "_subst P (CONST True) (_svid_post (CONST ok))"

end


theory Predicate_Formulas
imports
  "HOL-Library.Countable"
  "HOL-Library.Infinite_Set"
  "HOL-Eisbach.Eisbach"
  Abstract_Formula
begin

text \<open>This theory contains an example instantiation of @{term Abstract_Formulas} with an
formula type with local constants. It is a rather ad-hoc type that may not be very useful to
work with, though.\<close>

type_synonym var = nat
type_synonym lconst = nat

text \<open>
We support higher order variables, in order to express \<open>\<forall>x.?P x\<close>. But we stay first order,
i.e. the parameters of such a variables will only be instantiated with ground terms.
\<close>

datatype form =
    Var (var:var) (params: "form list")
  | LC (var:lconst)
  | Op (name:string) (params: "form list")
  | Quant (name:string) (var:nat) (body: form)

type_synonym schema = "var list \<times> form"

type_synonym subst = "(nat \<times> schema) list"

fun fv :: "form \<Rightarrow> var set" where
   "fv (Var v xs) = insert v (Union (fv ` set xs))"
 | "fv (LC v) = {}"
 | "fv (Op n xs) = Union (fv ` set xs)"
 | "fv (Quant n v f) = fv f - {v}"

definition fresh_for :: "var set \<Rightarrow> var" where
  "fresh_for V = (SOME n. n \<notin> V)"

lemma fresh_for_fresh: "finite V \<Longrightarrow> fresh_for V \<notin> V"
  unfolding fresh_for_def
  apply (rule someI2_ex)
   using infinite_nat_iff_unbounded_le
   apply auto
  done

text \<open>Free variables\<close>

fun fv_schema :: "schema \<Rightarrow> var set" where
  "fv_schema (ps,f) = fv f - set ps"

definition fv_subst :: "subst \<Rightarrow> var set" where
  "fv_subst s = \<Union>(fv_schema ` ran (map_of s))"

definition fv_subst1 where
  "fv_subst1 s = \<Union>(fv ` snd ` set s)"

lemma fv_subst_Nil[simp]: "fv_subst1 [] = {}"
  unfolding fv_subst1_def by auto

text \<open>Local constants, separate from free variables.\<close>

fun lc :: "form \<Rightarrow> lconst set" where
   "lc (Var v xs) = Union (lc ` set xs)"
 | "lc (LC c) = {c}"
 | "lc (Op n xs) = Union (lc ` set xs)"
 | "lc (Quant n v f) = lc f"

fun lc_schema :: "schema \<Rightarrow> lconst set" where
  "lc_schema (ps,f) = lc f"

definition lc_subst1 where
  "lc_subst1 s = \<Union>(lc ` snd ` set s)"

fun lc_subst :: "subst \<Rightarrow> lconst set" where
  "lc_subst s = \<Union>(lc_schema ` snd ` set s)"

fun map_lc :: "(lconst \<Rightarrow> lconst) \<Rightarrow> form \<Rightarrow> form" where
  "map_lc f (Var v xs) = Var v (map (map_lc f) xs)"
| "map_lc f (LC n) = LC (f n)"
| "map_lc f (Op n xs) = Op n (map (map_lc f) xs)"
| "map_lc f (Quant n v f') = Quant n v (map_lc f f')"

lemma fv_map_lc[simp]: "fv (map_lc p f) = fv f"
  by (induction f) auto

lemma lc_map_lc[simp]: "lc (map_lc p f) = p ` lc f"
  by (induction f) auto

lemma map_lc_map_lc[simp]: "map_lc p1 (map_lc p2 f) = map_lc (p1 \<circ> p2) f"
  by (induction f) auto

fun map_lc_subst1 :: "(lconst \<Rightarrow> lconst) \<Rightarrow> (var \<times> form) list \<Rightarrow> (var \<times> form) list" where
  "map_lc_subst1 f s = map (apsnd (map_lc f)) s"

fun map_lc_subst :: "(lconst \<Rightarrow> lconst) \<Rightarrow> subst \<Rightarrow> subst" where
  "map_lc_subst f s = map (apsnd (apsnd (map_lc f))) s"

lemma map_lc_noop[simp]: "lc f = {} \<Longrightarrow> map_lc p f = f"
  by (induction f) (auto simp add: map_idI)

lemma map_lc_cong[cong]: "(\<And>x. x \<in> lc f \<Longrightarrow> f1 x = f2 x) \<Longrightarrow> map_lc f1 f = map_lc f2 f"
  by (induction f) auto

lemma map_lc_subst_cong[cong]:
  assumes "(\<And>x. x \<in> lc_subst s \<Longrightarrow> f1 x = f2 x)"
  shows "map_lc_subst f1 s = map_lc_subst f2 s"
  by (force intro!: map_lc_cong assms)

text \<open>In order to make the termination checker happy, we define substitution in two stages: One
that substitutes only ground terms for variables, and the real one that can substitute schematic
terms (or lambda expression, if you want).\<close>

fun subst1 :: "(var \<times> form) list \<Rightarrow> form \<Rightarrow> form" where
    "subst1 s (Var v []) = (case map_of s v of Some f \<Rightarrow> f | None \<Rightarrow> Var v [])"
  | "subst1 s (Var v xs) = Var v xs"
  | "subst1 s (LC n) = LC n"
  | "subst1 s (Op n xs) = Op n (map (subst1 s) xs)"
  | "subst1 s (Quant n v f) =
      (if v \<in> fv_subst1 s then
      (let v' = fresh_for (fv_subst1 s)
      in Quant n v' (subst1 ((v, Var v' [])#s) f))
      else Quant n v (subst1 s f))"

lemma apsnd_def': "apsnd f = (\<lambda>(k, v). (k, f v))"
  by auto

lemma map_of_map_apsnd:
  "map_of (map (apsnd f) xs) = map_option f \<circ> map_of xs"
  unfolding apsnd_def' by (rule map_of_map)

lemma map_lc_subst1[simp]: "map_lc p (subst1 s f) = subst1 (map_lc_subst1 p s) (map_lc p f)"
  apply (induction s f rule: subst1.induct)
  apply (auto split: option.splits simp add: map_of_map_apsnd Let_def)
  apply (subst subst1.simps, auto split: option.splits)[1]
  apply (subst subst1.simps, auto split: option.splits)[1]
  apply (subst subst1.simps, auto split: option.splits)[1]
  apply (subst subst1.simps, auto split: option.splits)[1]
  apply (subst subst1.simps, auto split: option.splits, simp only: Let_def map_lc.simps)[1]
  apply (subst subst1.simps, auto split: option.splits)
  done

fun subst' :: "subst \<Rightarrow> form \<Rightarrow> form" where
    "subst' s (Var v xs) =
      (case map_of s v of None \<Rightarrow> (Var v (map (subst' s) xs))
                 | Some (ps,rhs) \<Rightarrow>
                     if length ps = length xs
                     then subst1 (zip ps (map (subst' s) xs)) rhs
                     else (Var v (map (subst' s) xs)))"
  | "subst' s (LC n) = LC n"
  | "subst' s (Op n xs) = Op n (map (subst' s) xs)"
  | "subst' s (Quant n v f) =
      (if v \<in> fv_subst s then
      (let v' = fresh_for (fv_subst s)
       in Quant n v' (subst' ((v,([], Var v' []))#s) f))
      else Quant n v (subst' s f))"

lemma subst'_Nil[simp]: "subst' [] f = f"
  by (induction f) (auto simp add: map_idI fv_subst_def)

lemma lc_subst': "lc (subst' s f) \<subseteq> lc f \<union> lc_subst s"
  apply (induction s f rule: subst'.induct)
     apply (auto split: option.splits dest: map_of_SomeD  dest!: subsetD[OF lc_subst1] simp add: fv_subst_def)
   apply (fastforce dest!: set_zip_rightD)+
  done

lemma ran_map_option_comp[simp]:
  "ran (map_option f \<circ> m) = f ` ran m"
unfolding comp_def by (rule ran_map_option)

lemma fv_schema_apsnd_map_lc[simp]:
  "fv_schema (apsnd (map_lc p) a) = fv_schema a"
by (cases a) auto

lemma fv_subst_map_apsnd_map_lc[simp]:
  "fv_subst (map (apsnd (apsnd (map_lc p))) s) = fv_subst s"
unfolding fv_subst_def
by (auto simp add: map_of_map_apsnd)

lemma map_apsnd_zip[simp]: "map (apsnd f) (zip a b) = zip a (map f b)"
  by (simp add: apsnd_def' zip_map2)

lemma map_lc_subst'[simp]: "map_lc p (subst' s f) = subst' (map_lc_subst p s) (map_lc p f)"
  apply (induction s f rule: subst'.induct)
     apply (auto split: option.splits dest: map_of_SomeD simp add: map_of_map_apsnd Let_def)
        apply (solves \<open>(subst subst'.simps, auto split: option.splits)[1]\<close>)
       apply (solves \<open>(subst subst'.simps, auto split: option.splits cong: map_cong)[1]\<close>)
      apply (solves \<open>(subst subst'.simps, auto split: option.splits)[1]\<close>)
     apply (solves \<open>(subst subst'.simps, auto split: option.splits)[1]\<close>)
    apply (solves \<open>(subst subst'.simps, auto split: option.splits)[1]\<close>)
   apply (solves \<open>(subst subst'.simps, auto split: option.splits, simp only: Let_def map_lc.simps)[1]\<close>)
  apply (solves \<open>(subst subst'.simps, auto split: option.splits)[1]\<close>)
done

text \<open>Since subst' happily renames quantified variables, we have a simple wrapper that
ensures that the substitution is minimal, and is empty if \<open>f\<close> is closed. This is
a hack to support lemma  \<open>subst_noop\<close>. \<close>

fun subst :: "subst \<Rightarrow> form \<Rightarrow> form" where
  "subst s f = subst' (filter (\<lambda> (v,s). v \<in> fv f) s) f"

lemma subst_Nil[simp]: "subst [] f = f"
  by auto

lemma subst_noop[simp]: "fv f = {} \<Longrightarrow> subst s f = f"
  by simp

lemma lc_subst: "lc (subst s f) \<subseteq> lc f \<union> lc_subst s"
  by (auto dest: subsetD[OF lc_subst'])

lemma lc_subst_map_lc_subst[simp]: "lc_subst (map_lc_subst p s) = p ` lc_subst s"
  by force

lemma map_lc_subst[simp]: "map_lc p (subst s f) = subst (map_lc_subst p s) (map_lc p f)"
  unfolding subst.simps
  by (auto simp add: filter_map intro!: arg_cong[OF filter_cong] )

fun closed :: "form \<Rightarrow> bool" where
  "closed f \<longleftrightarrow> fv f = {} \<and> lc f = {}"

interpretation predicate: Abstract_Formulas
  "curry to_nat :: nat \<Rightarrow> var \<Rightarrow> var"
  map_lc
  lc
  "closed"
  subst
  lc_subst
  map_lc_subst
  "Var 0 []"
  apply unfold_locales
  apply (solves fastforce)
  apply (solves fastforce)
  apply (solves fastforce)
  apply (solves fastforce)
  apply (solves fastforce)
  apply (solves \<open>rule lc_subst\<close>)
  apply (solves fastforce)
  apply (solves fastforce)
  apply (solves fastforce)
  apply (solves \<open>metis map_lc_subst_cong\<close>)
  apply (solves \<open>rule lc_subst_map_lc_subst\<close>)
  apply (solves simp)
  apply (solves \<open>rule exI[where x = "[]"], simp\<close>)
  apply (solves \<open>rename_tac f, rule_tac x = "[(0, ([],f))]" in exI, simp\<close>)
  done

declare predicate.subst_lconsts_empty_subst [simp del]

end


(* Author: Joshua Schneider, ETH Zurich *)

subsection \<open>Lists\<close>

theory Applicative_List imports
  Applicative
  "HOL-Library.Adhoc_Overloading"
begin

definition "ap_list fs xs = List.bind fs (\<lambda>f. List.bind xs (\<lambda>x. [f x]))"

adhoc_overloading Applicative.ap ap_list

lemma Nil_ap[simp]: "ap_list [] xs = []"
unfolding ap_list_def by simp

lemma ap_Nil[simp]: "ap_list fs [] = []"
unfolding ap_list_def by (induction fs) simp_all

lemma ap_list_transfer[transfer_rule]:
  "rel_fun (list_all2 (rel_fun A B)) (rel_fun (list_all2 A) (list_all2 B)) ap_list ap_list"
unfolding ap_list_def[abs_def] List.bind_def
by transfer_prover

context includes applicative_syntax
begin

lemma cons_ap_list: "(f # fs) \<diamondop> xs = map f xs @ fs \<diamondop> xs"
unfolding ap_list_def by (induction xs) simp_all

lemma append_ap_distrib: "(fs @ gs) \<diamondop> xs = fs \<diamondop> xs @ gs \<diamondop> xs"
unfolding ap_list_def by (induction fs) simp_all

applicative list
for
  pure: "\<lambda>x. [x]"
  ap: ap_list
  rel: list_all2
  set: set
proof -
  fix x :: "'a list"
  show "[\<lambda>x. x] \<diamondop> x = x" unfolding ap_list_def by (induction x) simp_all
next
  fix g :: "('b \<Rightarrow> 'c) list" and f :: "('a \<Rightarrow> 'b) list" and x
  let ?B = "\<lambda>g f x. g (f x)"
  show "[?B] \<diamondop> g \<diamondop> f \<diamondop> x = g \<diamondop> (f \<diamondop> x)"
  proof (induction g)
    case Nil show ?case by simp
  next
    case (Cons g gs)
    have g_comp: "[?B g] \<diamondop> f \<diamondop> x = [g] \<diamondop> (f \<diamondop> x)"
    proof (induction f)
      case Nil show ?case by simp
    next
      case (Cons f fs)
      have "[?B g] \<diamondop> (f # fs) \<diamondop> x = [g] \<diamondop> ([f] \<diamondop> x) @ [?B g] \<diamondop> fs \<diamondop> x"
        by (simp add: cons_ap_list)
      also have "... = [g] \<diamondop> ([f] \<diamondop> x) @ [g] \<diamondop> (fs \<diamondop> x)" using Cons.IH ..
      also have "... = [g] \<diamondop> ((f # fs) \<diamondop> x)" by (simp add: cons_ap_list)
      finally show ?case .
    qed
    have "[?B] \<diamondop> (g # gs) \<diamondop> f \<diamondop> x = [?B g] \<diamondop> f \<diamondop> x @ [?B] \<diamondop> gs \<diamondop> f \<diamondop> x"
      by (simp add: cons_ap_list append_ap_distrib)
    also have "... = [g] \<diamondop> (f \<diamondop> x) @ gs \<diamondop> (f \<diamondop> x)" using g_comp Cons.IH by simp
    also have "... = (g # gs) \<diamondop> (f \<diamondop> x)" by (simp add: cons_ap_list)
    finally show ?case .
  qed
next
  fix f :: "('a \<Rightarrow> 'b) list" and x
  show "f \<diamondop> [x] = [\<lambda>f. f x] \<diamondop> f" unfolding ap_list_def by simp
next
  fix R :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
  show "rel_fun R (list_all2 R) (\<lambda>x. [x]) (\<lambda>x. [x])" by transfer_prover
next
  fix R and f :: "('a \<Rightarrow> 'b) list" and g :: "('a \<Rightarrow> 'c) list" and x
  assume [transfer_rule]: "list_all2 (rel_fun (eq_on (set x)) R) f g"
  have [transfer_rule]: "list_all2 (eq_on (set x)) x x" by (simp add: list_all2_same)
  show "list_all2 R (f \<diamondop> x) (g \<diamondop> x)" by transfer_prover
qed (simp add: cons_ap_list)

lemma map_ap_conv[applicative_unfold]: "map f x = [f] \<diamondop> x"
unfolding ap_list_def List.bind_def
by simp

end

end