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

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

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

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

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

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

section {* Examples for Total Correctness *}

theory VcgExTotal imports "../HeapList" "../Vcg" begin

record 'g vars = "'g state" +
  A_' :: nat
  I_' :: nat
  M_' :: nat
  N_' :: nat
  R_' :: nat
  S_' :: nat
  Abr_':: string

lemma "\<Gamma>\<turnstile>\<^sub>t \<lbrace>\<acute>M = 0 \<and> \<acute>S = 0\<rbrace>
          WHILE \<acute>M \<noteq> a
          INV \<lbrace>\<acute>S = \<acute>M * b \<and> \<acute>M \<le> a\<rbrace>
          VAR MEASURE a - \<acute>M
          DO \<acute>S :== \<acute>S + b;; \<acute>M :== \<acute>M + 1 OD
          \<lbrace>\<acute>S = a * b\<rbrace>"
apply vcg
apply (auto)
done

lemma "\<Gamma>\<turnstile>\<^sub>t \<lbrace>\<acute>I \<le> 3\<rbrace>
     WHILE \<acute>I < 10 INV \<lbrace>\<acute>I\<le> 10\<rbrace> VAR MEASURE 10 - \<acute>I
     DO
       \<acute>I :== \<acute>I + 1
     OD
  \<lbrace>\<acute>I = 10\<rbrace>"
apply vcg
apply auto
done

text {* Total correctness of a nested loop. In the inner loop we have to
express that the loop variable of the outer loop is not changed. We use
@{text "FIX"} to introduce a new logical variable
*}

lemma "\<Gamma>\<turnstile>\<^sub>t \<lbrace>\<acute>M=0 \<and> \<acute>N=0\<rbrace>
      WHILE (\<acute>M < i)
      INV \<lbrace>\<acute>M \<le> i \<and> (\<acute>M \<noteq> 0 \<longrightarrow> \<acute>N = j) \<and> \<acute>N \<le> j\<rbrace>
      VAR MEASURE (i - \<acute>M)
      DO
         \<acute>N :== 0;;
         WHILE (\<acute>N < j)
         FIX m.
         INV \<lbrace>\<acute>M=m \<and> \<acute>N \<le> j\<rbrace>
         VAR MEASURE (j - \<acute>N)
         DO
           \<acute>N :== \<acute>N + 1
         OD;;
       \<acute>M :== \<acute>M + 1
       OD
       \<lbrace>\<acute>M=i \<and> (\<acute>M\<noteq>0 \<longrightarrow> \<acute>N=j)\<rbrace>"
apply vcg
apply simp_all
apply arith
done

primrec fac:: "nat \<Rightarrow> nat"
where
"fac 0 = 1" |
"fac (Suc n) = (Suc n) * fac n"

lemma fac_simp [simp]: "0 < i \<Longrightarrow>  fac i = i * fac (i - 1)"
  by (cases i) simp_all

procedures
  Fac (N | R) = "IF \<acute>N = 0 THEN \<acute>R :== 1
                       ELSE CALL Fac(\<acute>N - 1,\<acute>R);;
                            \<acute>R :== \<acute>N * \<acute>R
                       FI"

lemma (in Fac_impl) Fac_spec:
  shows "\<forall>n. \<Gamma>\<turnstile>\<^sub>t \<lbrace>\<acute>N=n\<rbrace> \<acute>R :== PROC Fac(\<acute>N) \<lbrace>\<acute>R = fac n\<rbrace>"
  apply (hoare_rule HoareTotal.ProcRec1 [where r="measure (\<lambda>(s,p). \<^bsup>s\<^esup>N)"])
  apply vcg
  apply simp
  done

procedures
  p91(R,N | R) = "IF 100 < \<acute>N THEN \<acute>R :== \<acute>N - 10
                      ELSE \<acute>R :== CALL p91(\<acute>R,\<acute>N+11);;
                           \<acute>R :== CALL p91(\<acute>R,\<acute>R) FI"

  p91_spec: "\<forall>n. \<Gamma>\<turnstile>\<^sub>t \<lbrace>\<acute>N=n\<rbrace> \<acute>R :== PROC p91(\<acute>R,\<acute>N)
                        \<lbrace>if 100 < n then \<acute>R = n - 10 else \<acute>R = 91\<rbrace>,{}"

lemma (in p91_impl) p91_spec:
  shows "\<forall>\<sigma>. \<Gamma>\<turnstile>\<^sub>t {\<sigma>} \<acute>R :== PROC p91(\<acute>R,\<acute>N)
                       \<lbrace>if 100 < \<^bsup>\<sigma>\<^esup>N then \<acute>R = \<^bsup>\<sigma>\<^esup>N - 10 else \<acute>R = 91\<rbrace>,{}"
  apply (hoare_rule HoareTotal.ProcRec1 [where r="measure (\<lambda>(s,p). 101 - \<^bsup>s\<^esup>N)"])
  apply vcg
  apply clarsimp
  apply arith
  done

record globals_list =
  next_' :: "ref \<Rightarrow> ref"
  cont_' :: "ref \<Rightarrow> nat"

record 'g list_vars = "'g state" +
  p_'    :: "ref"
  q_'    :: "ref"
  r_'    :: "ref"
  root_' :: "ref"
  tmp_'  :: "ref"

procedures
  append(p,q|p) =
    "IF \<acute>p=Null THEN \<acute>p :== \<acute>q ELSE \<acute>p\<rightarrow>\<acute>next :== CALL append(\<acute>p\<rightarrow>\<acute>next,\<acute>q) FI"

lemma (in append_impl)
  shows
   "\<forall>\<sigma> Ps Qs. \<Gamma>\<turnstile>\<^sub>t
      \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps \<and>  List \<acute>q \<acute>next Qs \<and> set Ps \<inter> set Qs = {} \<rbrace>
       \<acute>p :== PROC append(\<acute>p,\<acute>q)
      \<lbrace>List \<acute>p \<acute>next (Ps@Qs) \<and> (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"
   apply (hoare_rule HoareTotal.ProcRec1
            [where r="measure (\<lambda>(s,p). length (list \<^bsup>s\<^esup>p \<^bsup>s\<^esup>next))"])
   apply vcg
   apply (fastforce  simp add: List_list)
   done

lemma (in append_impl)
  shows
   "\<forall>\<sigma> Ps Qs. \<Gamma>\<turnstile>\<^sub>t
      \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps \<and>  List \<acute>q \<acute>next Qs \<and> set Ps \<inter> set Qs = {} \<rbrace>
       \<acute>p :== PROC append(\<acute>p,\<acute>q)
      \<lbrace>List \<acute>p \<acute>next (Ps@Qs) \<and> (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"
   apply (hoare_rule HoareTotal.ProcRec1
            [where r="measure (\<lambda>(s,p). length (list \<^bsup>s\<^esup>p \<^bsup>s\<^esup>next))"])
   apply vcg
   apply (fastforce  simp add: List_list)
   done

lemma (in append_impl)
  shows
  append_spec:
   "\<forall>\<sigma>. \<Gamma>\<turnstile>\<^sub>t ({\<sigma>} \<inter> \<lbrace>islist \<acute>p \<acute>next\<rbrace>)  \<acute>p :== PROC append(\<acute>p,\<acute>q)
    \<lbrace>\<forall>Ps Qs. List \<^bsup>\<sigma>\<^esup>p \<^bsup>\<sigma>\<^esup>next Ps \<and>  List \<^bsup>\<sigma>\<^esup>q \<^bsup>\<sigma>\<^esup>next Qs \<and> set Ps \<inter> set Qs = {}
     \<longrightarrow>
     List \<acute>p \<acute>next (Ps@Qs) \<and> (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"
   apply (hoare_rule HoareTotal.ProcRec1
            [where r="measure (\<lambda>(s,p). length (list \<^bsup>s\<^esup>p \<^bsup>s\<^esup>next))"])
   apply vcg
   apply fastforce
   done

lemma "\<Gamma>\<turnstile>\<lbrace>List \<acute>p \<acute>next Ps\<rbrace>
       \<acute>q :== Null;;
       WHILE \<acute>p \<noteq> Null INV \<lbrace>\<exists>Ps' Qs'. List \<acute>p \<acute>next Ps' \<and> List \<acute>q \<acute>next Qs' \<and>
                             set Ps' \<inter> set Qs' = {} \<and>
                             rev Ps' @ Qs' = rev Ps\<rbrace>
        DO
         \<acute>r :== \<acute>p;; \<acute>p :== \<acute>p\<rightarrow>\<acute>next;;
         \<acute>r\<rightarrow>\<acute>next :== \<acute>q;; \<acute>q :== \<acute>r
       OD;;
       \<acute>p :==\<acute>q
       \<lbrace>List \<acute>p \<acute>next (rev Ps)\<rbrace> "
apply vcg
apply   clarsimp
apply  clarsimp
apply force
apply simp
done

lemma conjI2: "\<lbrakk>Q; Q \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P \<and> Q"
by blast

procedures Rev(p|p) =
      "\<acute>q :== Null;;
       WHILE \<acute>p \<noteq> Null
       DO
         \<acute>r :== \<acute>p;; \<lbrace>\<acute>p \<noteq> Null\<rbrace>\<longmapsto> \<acute>p :== \<acute>p\<rightarrow>\<acute>next;;
         \<lbrace>\<acute>r \<noteq> Null\<rbrace>\<longmapsto> \<acute>r\<rightarrow>\<acute>next :== \<acute>q;; \<acute>q :== \<acute>r
       OD;;
       \<acute>p :==\<acute>q"
 Rev_spec:
  "\<forall>Ps. \<Gamma>\<turnstile>\<^sub>t \<lbrace>List \<acute>p \<acute>next Ps\<rbrace> \<acute>p :== PROC Rev(\<acute>p) \<lbrace>List \<acute>p \<acute>next (rev Ps)\<rbrace>"
 Rev_modifies:
  "\<forall>\<sigma>. \<Gamma>\<turnstile>\<^bsub>/UNIV\<^esub> {\<sigma>} \<acute>p :== PROC Rev(\<acute>p) {t. t may_only_modify_globals \<sigma> in [next]}"

text {* We only need partial correctness of modifies clause!*}

lemma upd_hd_next:
  assumes p_ps: "List p next (p#ps)"
  shows "List (next p) (next(p := q)) ps"
proof -
  from p_ps
  have "p \<notin> set ps"
    by auto
  with p_ps show ?thesis
    by simp
qed

lemma (in Rev_impl) shows
 Rev_spec:
  "\<forall>Ps. \<Gamma>\<turnstile>\<^sub>t \<lbrace>List \<acute>p \<acute>next Ps\<rbrace> \<acute>p :== PROC Rev(\<acute>p) \<lbrace>List \<acute>p \<acute>next (rev Ps)\<rbrace>"
apply (hoare_rule HoareTotal.ProcNoRec1)
apply (hoare_rule anno =
       "\<acute>q :== Null;;
       WHILE \<acute>p \<noteq> Null INV \<lbrace>\<exists>Ps' Qs'. List \<acute>p \<acute>next Ps' \<and> List \<acute>q \<acute>next Qs' \<and>
                             set Ps' \<inter> set Qs' = {} \<and>
                             rev Ps' @ Qs' = rev Ps\<rbrace>
       VAR MEASURE (length (list \<acute>p \<acute>next) )
        DO
         \<acute>r :== \<acute>p;; \<lbrace>\<acute>p \<noteq> Null\<rbrace>\<longmapsto>\<acute>p :== \<acute>p\<rightarrow>\<acute>next;;
         \<lbrace>\<acute>r \<noteq> Null\<rbrace>\<longmapsto>\<acute>r\<rightarrow>\<acute>next :== \<acute>q;; \<acute>q :== \<acute>r
       OD;;
       \<acute>p :==\<acute>q" in HoareTotal.annotateI)
apply vcg
apply   clarsimp
apply  clarsimp
apply  (rule conjI2)
apply   force
apply  clarsimp
apply  (subgoal_tac "List p next (p#ps)")
prefer 2 apply simp
apply  (frule_tac q=q in upd_hd_next)
apply  (simp only: List_list)
apply  simp
apply simp
done

lemma (in Rev_impl) shows
 Rev_modifies:
  "\<forall>\<sigma>. \<Gamma>\<turnstile>\<^bsub>/UNIV \<^esub>{\<sigma>} \<acute>p :== PROC Rev(\<acute>p) {t. t may_only_modify_globals \<sigma> in [next]}"
apply (hoare_rule HoarePartial.ProcNoRec1)
apply (vcg spec=modifies)
done

lemma "\<Gamma>\<turnstile>\<^sub>t \<lbrace>List \<acute>p \<acute>next Ps\<rbrace>
       \<acute>q :== Null;;
       WHILE \<acute>p \<noteq> Null INV \<lbrace>\<exists>Ps' Qs'. List \<acute>p \<acute>next Ps' \<and> List \<acute>q \<acute>next Qs' \<and>
                             set Ps' \<inter> set Qs' = {} \<and>
                             rev Ps' @ Qs' = rev Ps\<rbrace>
       VAR MEASURE (length (list \<acute>p \<acute>next) )
        DO
         \<acute>r :== \<acute>p;; \<acute>p :== \<acute>p\<rightarrow>\<acute>next;;
         \<acute>r\<rightarrow>\<acute>next :== \<acute>q;; \<acute>q :== \<acute>r
       OD;;
       \<acute>p :==\<acute>q
       \<lbrace>List \<acute>p \<acute>next (rev Ps)\<rbrace> "
apply vcg
apply   clarsimp
apply  clarsimp
apply  (rule conjI2)
apply   force
apply  clarsimp
apply  (subgoal_tac "List p next (p#ps)")
prefer 2 apply simp
apply  (frule_tac q=q in upd_hd_next)
apply  (simp only: List_list)
apply  simp
apply simp
done

procedures
  pedal(N,M) = "IF 0 < \<acute>N THEN
                            IF 0 < \<acute>M THEN CALL coast(\<acute>N- 1,\<acute>M- 1) FI;;
                            CALL pedal(\<acute>N- 1,\<acute>M)
                         FI"

and

  coast(N,M) = "CALL pedal(\<acute>N,\<acute>M);;
                         IF 0 < \<acute>M THEN CALL coast(\<acute>N,\<acute>M- 1) FI"

ML {* ML_Thms.bind_thm ("HoareTotal_ProcRec2", Hoare.gen_proc_rec @{context} Hoare.Total 2)*}

lemma (in pedal_coast_clique)
  shows "(\<Gamma>\<turnstile>\<^sub>t \<lbrace>True\<rbrace>  PROC pedal(\<acute>N,\<acute>M) \<lbrace>True\<rbrace>) \<and>
         (\<Gamma>\<turnstile>\<^sub>t \<lbrace>True\<rbrace> PROC coast(\<acute>N,\<acute>M) \<lbrace>True\<rbrace>)"
  apply (hoare_rule HoareTotal_ProcRec2
          [where ?r= "inv_image (measure (\<lambda>m. m) <*lex*>
                                  measure (\<lambda>p. if p = coast_'proc then 1 else 0))
                      (\<lambda>(s,p). (\<^bsup>s\<^esup>N + \<^bsup>s\<^esup>M,p))"])
  apply simp_all
  apply  vcg
  apply  simp
  apply vcg
  apply simp
  done

lemma (in pedal_coast_clique)
  shows "(\<Gamma>\<turnstile>\<^sub>t \<lbrace>True\<rbrace> PROC pedal(\<acute>N,\<acute>M) \<lbrace>True\<rbrace>) \<and>
         (\<Gamma>\<turnstile>\<^sub>t \<lbrace>True\<rbrace> PROC coast(\<acute>N,\<acute>M) \<lbrace>True\<rbrace>)"
  apply (hoare_rule HoareTotal_ProcRec2
          [where ?r= "inv_image (measure (\<lambda>m. m) <*lex*>
                                  measure (\<lambda>p. if p = coast_'proc then 1 else 0))
                      (\<lambda>(s,p). (\<^bsup>s\<^esup>N + \<^bsup>s\<^esup>M,p))"])
  apply simp_all
  apply  vcg
  apply  simp
  apply vcg
  apply simp
  done

lemma (in pedal_coast_clique)
  shows "(\<Gamma>\<turnstile>\<^sub>t \<lbrace>True\<rbrace> PROC pedal(\<acute>N,\<acute>M) \<lbrace>True\<rbrace>) \<and>
         (\<Gamma>\<turnstile>\<^sub>t \<lbrace>True\<rbrace> PROC coast(\<acute>N,\<acute>M) \<lbrace>True\<rbrace>)"
  apply(hoare_rule HoareTotal_ProcRec2
     [where ?r= "measure (\<lambda>(s,p). \<^bsup>s\<^esup>N + \<^bsup>s\<^esup>M + (if p = coast_'proc then 1 else 0))"])
  apply simp_all
  apply  vcg
  apply  simp
  apply  arith
  apply vcg
  apply simp
  done

lemma (in pedal_coast_clique)
  shows "(\<Gamma>\<turnstile>\<^sub>t \<lbrace>True\<rbrace> PROC pedal(\<acute>N,\<acute>M) \<lbrace>True\<rbrace>) \<and>
         (\<Gamma>\<turnstile>\<^sub>t \<lbrace>True\<rbrace> PROC coast(\<acute>N,\<acute>M) \<lbrace>True\<rbrace>)"
  apply(hoare_rule HoareTotal_ProcRec2
     [where ?r= "(\<lambda>(s,p). \<^bsup>s\<^esup>N) <*mlex*> (\<lambda>(s,p). \<^bsup>s\<^esup>M) <*mlex*>
                 measure (\<lambda>(s,p). if p = coast_'proc then 1 else 0)"])
   apply  simp_all
   apply  vcg
   apply  simp
   apply vcg
   apply simp
   done

lemma (in pedal_coast_clique)
  shows "(\<Gamma>\<turnstile>\<^sub>t \<lbrace>True\<rbrace> PROC pedal(\<acute>N,\<acute>M) \<lbrace>True\<rbrace>) \<and>
         (\<Gamma>\<turnstile>\<^sub>t \<lbrace>True\<rbrace> PROC coast(\<acute>N,\<acute>M) \<lbrace>True\<rbrace>)"
  apply(hoare_rule HoareTotal_ProcRec2
     [where ?r= "measure (\<lambda>s. \<^bsup>s\<^esup>N + \<^bsup>s\<^esup>M) <*lex*>
                 measure (\<lambda>p. if p = coast_'proc then 1 else 0)"])
   apply simp_all
   apply  vcg
   apply  simp
   apply vcg
   apply simp
   done

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section {* \isaheader{State Space Exploration} *}
theory Exploration
imports Main "../../ICF/Collections"
begin
text_raw {*\label{thy:Exploration}*}

text {*
  In this theory, a workset algorithm for state-space exploration is defined.
  It explores the set of states that are reachable by a given relation,
   starting at a given set of initial states.

  The specification makes use of the data refinement framework for
  while-algorithms (cf. Section~\ref{thy:DatRef}), and is thus suited for
  being refined to an executable algorithm, using the Isabelle Collections Framework
  to provide the necessary data structures.
  *}

subsection "Generic Search Algorithm"

  -- "The algorithm contains a set of discovered states and a workset"
type_synonym '\<Sigma> sse_state = "'\<Sigma> set \<times> '\<Sigma> set"

  -- "Loop body"
inductive_set
  sse_step :: "('\<Sigma>\<times>'\<Sigma>) set \<Rightarrow> ('\<Sigma> sse_state \<times> '\<Sigma> sse_state) set"
  for R where
  "\<lbrakk> \<sigma>\<in>W;
     \<Sigma>' = \<Sigma> \<union> (R``{\<sigma>});
     W' = (W-{\<sigma>}) \<union> ((R``{\<sigma>}) - \<Sigma>)
   \<rbrakk> \<Longrightarrow> ((\<Sigma>,W),(\<Sigma>',W'))\<in>sse_step R"

  -- "Loop condition"
definition sse_cond :: "'\<Sigma> sse_state set" where
  "sse_cond = {(\<Sigma>,W). W\<noteq>{}}"

  -- "Initial state"
definition sse_initial :: "'\<Sigma> set \<Rightarrow> '\<Sigma> sse_state" where
  "sse_initial \<Sigma>i == (\<Sigma>i,\<Sigma>i)"

  -- {*Invariants:
  \begin{itemize}
    \item The workset contains only states that are already
      discovered.
    \item All discovered states are target states
    \item If there is a target state that is not discovered yet,
          then there is an element in the workset from that this
          target state is reachable without using discovered
          states as intermediate states. This supports the intuition
          of the workset as a frontier between the sets of discovered
          and undiscovered states.

  \end{itemize}*}
definition sse_invar :: "'\<Sigma> set \<Rightarrow> ('\<Sigma>\<times>'\<Sigma>) set \<Rightarrow> '\<Sigma> sse_state set" where
  "sse_invar \<Sigma>i R = {(\<Sigma>,W).
    W\<subseteq>\<Sigma> \<and>
    (\<Sigma> \<subseteq> R\<^sup>*``\<Sigma>i) \<and>
    (\<forall>\<sigma>\<in>(R\<^sup>*``\<Sigma>i)-\<Sigma>. \<exists>\<sigma>h\<in>W. (\<sigma>h,\<sigma>)\<in>(R - (UNIV \<times> \<Sigma>))\<^sup>*)
  }"

definition "sse_algo \<Sigma>i R ==
  \<lparr> wa_cond=sse_cond,
    wa_step=sse_step R,
    wa_initial = {sse_initial \<Sigma>i},
    wa_invar = sse_invar \<Sigma>i R \<rparr>"

definition "sse_term_rel \<Sigma>i R ==
  { (\<sigma>',\<sigma>). \<sigma>\<in>sse_invar \<Sigma>i R \<and> (\<sigma>,\<sigma>')\<in>sse_step R }"

  -- "Termination: Either a new state is discovered, or the workset shrinks"
theorem sse_term:
  assumes finite[simp, intro!]: "finite (R\<^sup>*``\<Sigma>i)"
  shows "wf (sse_term_rel \<Sigma>i R)"
proof -
  have "wf (({(\<Sigma>',\<Sigma>). \<Sigma> \<subset> \<Sigma>' \<and> \<Sigma>' \<subseteq> (R\<^sup>*``\<Sigma>i)}) <*lex*> finite_psubset)"
    by (auto intro: wf_bounded_supset)
  moreover have "sse_term_rel \<Sigma>i R \<subseteq> \<dots>" (is "_ \<subseteq> ?R")
  proof
    fix S
    assume A: "S\<in>sse_term_rel \<Sigma>i R"
    obtain \<Sigma> W \<Sigma>' W' \<sigma> where
      [simp]: "S=((\<Sigma>',W'),(\<Sigma>,W))" and
      S: "(\<Sigma>,W) \<in> sse_invar \<Sigma>i R"
         "\<sigma>\<in>W"
         "\<Sigma>' = \<Sigma> \<union> R``{\<sigma>}"
         "W' = (W-{\<sigma>}) \<union> (R``{\<sigma>} - \<Sigma>)"
    proof -
      obtain \<Sigma> W \<Sigma>' W' where SF[simp]: "S=((\<Sigma>',W'),(\<Sigma>,W))" by (cases S) force
      from A have R: "(\<Sigma>,W) \<in> sse_invar \<Sigma>i R" "((\<Sigma>,W),(\<Sigma>',W'))\<in>sse_step R"
        by (auto simp add: sse_term_rel_def)
      from sse_step.cases[OF R(2)] obtain \<sigma> where S:
        "\<sigma>\<in>W"
        "\<Sigma>' = \<Sigma> \<union> R``{\<sigma>}"
        "W' = (W-{\<sigma>}) \<union> (R``{\<sigma>} - \<Sigma>)"
        by metis
      thus ?thesis
        by (rule_tac that[OF SF R(1) S])
    qed

    from S(1) have
      [simp, intro!]: "finite \<Sigma>" "finite W" and
      WSS: "W\<subseteq>\<Sigma>" and
      SSS: "\<Sigma>\<subseteq>R\<^sup>*``\<Sigma>i"
      by (auto simp add: sse_invar_def intro: finite_subset)

    show "S\<in>?R" proof (cases "R``{\<sigma>} \<subseteq> \<Sigma>")
      case True with S have "\<Sigma>'=\<Sigma>" "W' \<subset> W" by auto
      thus ?thesis by (simp)
    next
      case False
      with S have "\<Sigma>' \<supset> \<Sigma>" by auto
      moreover from S(2) WSS SSS have "\<sigma>\<in>R\<^sup>*``\<Sigma>i" by auto
      hence "R``{\<sigma>} \<subseteq> R\<^sup>*``\<Sigma>i"
        by (auto intro: rtrancl_into_rtrancl)
      with S(3) SSS have "\<Sigma>' \<subseteq> R\<^sup>*``\<Sigma>i" by auto
      ultimately show ?thesis by simp
    qed
  qed
  ultimately show ?thesis by (auto intro: wf_subset)
qed

lemma sse_invar_initial: "(sse_initial \<Sigma>i) \<in> sse_invar \<Sigma>i R"
  by (unfold sse_invar_def sse_initial_def)
     (auto elim: rtrancl_last_touch)

  -- "Correctness theorem: If the loop terminates, the discovered states are
       exactly the reachable states"
theorem sse_invar_final:
  "\<forall>S. S\<in>wa_invar (sse_algo \<Sigma>i R) \<and> S\<notin>wa_cond (sse_algo \<Sigma>i R)
    \<longrightarrow> fst S = R\<^sup>*``\<Sigma>i"
  by (intro allI, case_tac S)
     (auto simp add: sse_invar_def sse_cond_def sse_algo_def)

lemma sse_invar_step: "\<lbrakk>S\<in>sse_invar \<Sigma>i R; (S,S')\<in>sse_step R\<rbrakk>
  \<Longrightarrow> S'\<in>sse_invar \<Sigma>i R"
  -- "Split the goal by the invariant:"
  apply (cases S, cases S')
  apply clarsimp
  apply (erule sse_step.cases)
  apply clarsimp
  apply (subst sse_invar_def)
  apply (simp add: Let_def split_conv)
  apply (intro conjI)
  -- "Solve the easy parts automatically"
  apply (auto simp add: sse_invar_def) [3]
  apply (force simp add: sse_invar_def
               dest: rtrancl_into_rtrancl) [1]
  -- "Tackle the complex part (last part of the invariant) in Isar"
proof (intro ballI)
  fix \<sigma> W \<Sigma> \<sigma>'
  assume A:
    "(\<Sigma>,W)\<in>sse_invar \<Sigma>i R"
    "\<sigma>\<in>W"
    "\<sigma>'\<in>R\<^sup>* `` \<Sigma>i - (\<Sigma> \<union> R `` {\<sigma>})"
    -- "Using the invariant of the original state, we obtain
        a state in the original workset and a path not touching
        the originally discovered states"
  from A(3) have "\<sigma>' \<in> R\<^sup>* `` \<Sigma>i - \<Sigma>" by auto
  with A(1) obtain \<sigma>h where IP:
    "\<sigma>h\<in>W"
    "(\<sigma>h,\<sigma>')\<in>(R - (UNIV \<times> \<Sigma>))\<^sup>*"
  and SS:
    "W\<subseteq>\<Sigma>"
    "\<Sigma>\<subseteq>R\<^sup>* `` \<Sigma>i"
    by (unfold sse_invar_def) force

  -- {* We now make a case distinction, whether the obtained path contains
      states from @{term "post \<sigma>"} or not: *}
  from IP(2) show "\<exists>\<sigma>h\<in>W - {\<sigma>} \<union> (R `` {\<sigma>} - \<Sigma>).
                     (\<sigma>h, \<sigma>') \<in> (R - UNIV \<times> (\<Sigma> \<union> R `` {\<sigma>}))\<^sup>*"
  proof (cases rule: rtrancl_last_visit[where S="R `` {\<sigma>}"])
    case no_visit
    -- {* In the case that the obtained path contains no states from
          @{term "post \<sigma>"}, we can take it. *}
    hence G1: "(\<sigma>h,\<sigma>')\<in>(R- (UNIV \<times> (\<Sigma>\<union>R `` {\<sigma>})))\<^sup>*"
      by (simp add: set_diff_diff_left Sigma_Un_distrib2)
    moreover have "\<sigma>h \<noteq> \<sigma>"
      -- {* We may exclude the case that our obtained path started at
            @{text \<sigma>}, as all successors of @{text \<sigma>} are
            in @{term "R `` {\<sigma>}"} *}
    proof
      assume [simp]: "\<sigma>h=\<sigma>"
      from A SS have "\<sigma>\<noteq>\<sigma>'" by auto
      with G1 show False
        by (auto simp add: elim: converse_rtranclE)
    qed
    ultimately show ?thesis using IP(1) by auto
  next
    case (last_visit_point \<sigma>t)
    -- {* If the obtained path contains a state from @{text "R `` {\<sigma>}"},
          we simply pick the last one: *}
    hence "(\<sigma>t,\<sigma>')\<in>(R- (UNIV \<times> (\<Sigma>\<union>R `` {\<sigma>})))\<^sup>*"
      by (simp add: set_diff_diff_left Sigma_Un_distrib2)
    moreover from last_visit_point(2) have "\<sigma>t\<notin>\<Sigma>"
      by (auto elim: trancl.cases)
    ultimately show ?thesis using last_visit_point(1) by auto
  qed
qed

-- "The sse-algorithm is a well-defined while-algorithm"
theorem sse_while_algo: "finite (R\<^sup>*``\<Sigma>i) \<Longrightarrow> while_algo (sse_algo \<Sigma>i R)"
  apply unfold_locales
  apply (auto simp add: sse_algo_def intro: sse_invar_step sse_invar_initial)
  apply (drule sse_term)
  apply (erule_tac wf_subset)
  apply (unfold sse_term_rel_def)
  apply auto
  done

subsection "Depth First Search"
text_raw {*\label{sec:sse:dfs}*}
text {*
  In this section, the generic state space exploration algorithm is refined
  to a DFS-algorithm, that uses a stack to implement the workset.
*}

type_synonym '\<Sigma> dfs_state = "'\<Sigma> set \<times> '\<Sigma> list"

definition dfs_\<alpha> :: "'\<Sigma> dfs_state \<Rightarrow> '\<Sigma> sse_state"
  where "dfs_\<alpha> S == let (\<Sigma>,W)=S in (\<Sigma>,set W)"

definition dfs_invar_add :: "'\<Sigma> dfs_state set"
  where "dfs_invar_add == {(\<Sigma>,W). distinct W}"

definition "dfs_invar \<Sigma>i R == dfs_invar_add \<inter> { s. dfs_\<alpha> s \<in> sse_invar \<Sigma>i R }"

inductive_set dfs_initial :: "'\<Sigma> set \<Rightarrow> '\<Sigma> dfs_state set" for \<Sigma>i
  where "\<lbrakk> distinct W; set W = \<Sigma>i\<rbrakk> \<Longrightarrow> (\<Sigma>i,W)\<in>dfs_initial \<Sigma>i"

inductive_set dfs_step :: "('\<Sigma>\<times>'\<Sigma>) set \<Rightarrow> ('\<Sigma> dfs_state \<times>'\<Sigma> dfs_state) set"
  for R where
  "\<lbrakk> W=\<sigma>#Wtl;
     distinct Wn;
     set Wn = R``{\<sigma>} - \<Sigma>;
     W' = Wn@Wtl;
     \<Sigma>' = R``{\<sigma>} \<union> \<Sigma>
  \<rbrakk> \<Longrightarrow> ((\<Sigma>,W),(\<Sigma>',W'))\<in>dfs_step R"

definition dfs_cond :: "'\<Sigma> dfs_state set"
  where "dfs_cond == { (\<Sigma>,W). W\<noteq>[]}"

definition "dfs_algo \<Sigma>i R == \<lparr>
  wa_cond = dfs_cond,
  wa_step = dfs_step R,
  wa_initial = dfs_initial \<Sigma>i,
  wa_invar = dfs_invar \<Sigma>i R \<rparr>"

  -- "The DFS-algorithm refines the state-space exploration algorithm"
theorem dfs_pref_sse:
  "wa_precise_refine (dfs_algo \<Sigma>i R) (sse_algo \<Sigma>i R) dfs_\<alpha>"
  apply (unfold_locales)
  apply (auto simp add: dfs_algo_def sse_algo_def dfs_cond_def sse_cond_def
                        dfs_\<alpha>_def)
  apply (erule dfs_step.cases)
  apply (rule_tac \<sigma>=\<sigma> in sse_step.intros)
  apply (auto simp add: dfs_invar_def sse_invar_def dfs_invar_add_def
                        sse_initial_def dfs_\<alpha>_def
              elim: dfs_initial.cases)
  done

  -- "The DFS-algorithm is a well-defined while-algorithm"

  have [simp]: "wa_invar (sse_algo \<Sigma>i R) = sse_invar \<Sigma>i R"
    by (simp add: sse_algo_def)

  show ?thesis
    apply (rule wa_intro)
    apply (simp add: sse_while_algo)

    apply (simp add: dfs_invar_def dfs_algo_def)

    apply (auto simp add: dfs_invar_add_def dfs_algo_def dfs_\<alpha>_def
                          dfs_cond_def sse_invar_def
                elim!: dfs_step.cases) [1]

    apply (auto simp add: dfs_invar_add_def dfs_algo_def
                elim: dfs_initial.cases) [1]
    done
qed

  -- "The result of the DFS-algorithm is correct"
lemmas dfs_invar_final =
  wa_precise_refine.transfer_correctness[OF dfs_pref_sse sse_invar_final]

end


theory Subtyping
  imports Cogent
begin

text \<open>
  This file covers the interpretation of the subtyping relation as a lattice. This is how the
  compiler computes subtyping (as of late 2018), and these proofs give assurance we've formalised
  the correct relation.
\<close>

inductive type_lub :: "kind env \<Rightarrow> type \<Rightarrow> type \<Rightarrow> type \<Rightarrow> bool" ("_ \<turnstile> _ \<leftarrow> _ \<squnion> _" [60,0,0,60] 60)
  and type_glb :: "kind env \<Rightarrow> type \<Rightarrow> type \<Rightarrow> type \<Rightarrow> bool" ("_ \<turnstile> _ \<leftarrow> _ \<sqinter> _" [60,0,0,60] 60)
  where
  lub_tvar   : "\<lbrakk> n = n1
                ; n2 = n1
                \<rbrakk> \<Longrightarrow> K \<turnstile> TVar n \<leftarrow> TVar n1 \<squnion> TVar n2"
| lub_tvarb  : "\<lbrakk> n = n1
                ; n2 = n1
                \<rbrakk> \<Longrightarrow> K \<turnstile> TVarBang n \<leftarrow> TVarBang n1 \<squnion> TVarBang n2"
| lub_tcon   : "\<lbrakk> n = n1 ; n2 = n1
                ; s = s1 ; s2 = s1
                ; ts = ts1 ; ts1 = ts2
                \<rbrakk> \<Longrightarrow> K \<turnstile> TCon n ts s \<leftarrow> TCon n1 ts1 s1 \<squnion> TCon n2 ts2 s2"
| lub_tfun   : "\<lbrakk> K \<turnstile> t \<leftarrow> t1 \<sqinter> t2
                ; K \<turnstile> u \<leftarrow> u1 \<squnion> u2
                \<rbrakk> \<Longrightarrow> K \<turnstile> TFun t u \<leftarrow> TFun t1 u1 \<squnion> TFun t2 u2"
| lub_tprim  : "\<lbrakk> p = p1
                ; p2 = p1
                \<rbrakk> \<Longrightarrow> K \<turnstile> TPrim p \<leftarrow> TPrim p1 \<squnion> TPrim p2"
| lub_trecord: "\<lbrakk> list_all3 (\<lambda>p p1 p2. (K \<turnstile> (fst (snd p)) \<leftarrow> (fst (snd p1)) \<squnion> (fst (snd p2)))) ts ts1 ts2
                ; list_all3 (\<lambda>p p1 p2. let b = snd (snd p)
                                         ; b1 = snd (snd p1)
                                         ; b2 = snd (snd p2)
                                        in
                                          (if (K \<turnstile> fst (snd p1) :\<kappa> {D})
                                          then b1 \<le> b
                                          else b1 = b) \<and>
                                          (if (K \<turnstile> fst (snd p2) :\<kappa> {D})
                                          then b2 \<le> b
                                          else b2 = b)) ts ts1 ts2
                ; map fst ts = map fst ts1
                ; map fst ts1 = map fst ts2
                ; s = s1 ; s1 = s2
                \<rbrakk> \<Longrightarrow> K \<turnstile> TRecord ts s \<leftarrow> TRecord ts1 s1 \<squnion> TRecord ts2 s2"
| lub_tprod  : "\<lbrakk> K \<turnstile> t \<leftarrow> t1 \<squnion> t2
                ; K \<turnstile> u \<leftarrow> u1 \<squnion> u2
                \<rbrakk> \<Longrightarrow> K \<turnstile> TProduct t u \<leftarrow> TProduct t1 u1 \<squnion> TProduct t2 u2"
| lub_tsum   : "\<lbrakk> list_all3 (\<lambda>p p1 p2. (K \<turnstile> (fst (snd p)) \<leftarrow> (fst (snd p1)) \<squnion> (fst (snd p2)))) ts ts1 ts2
                ; list_all3 (\<lambda>p p1 p2. snd (snd p) = sup (snd (snd p1)) (snd (snd p2))) ts ts1 ts2
                ; map fst ts = map fst ts1
                ; map fst ts1 = map fst ts2
                \<rbrakk> \<Longrightarrow> K \<turnstile> TSum ts \<leftarrow> TSum ts1 \<squnion> TSum ts2"
| lub_tunit  : "K \<turnstile> TUnit \<leftarrow> TUnit \<squnion> TUnit"

| glb_tvar   : "\<lbrakk> n = n1
                ; n2 = n1
                \<rbrakk> \<Longrightarrow> K \<turnstile> TVar n \<leftarrow> TVar n1 \<sqinter> TVar n2"
| glb_tvarb  : "\<lbrakk> n = n1
                ; n2 = n1
                \<rbrakk> \<Longrightarrow> K \<turnstile> TVarBang n \<leftarrow> TVarBang n1 \<sqinter> TVarBang n2"
| glb_tcon   : "\<lbrakk> n = n1 ; n2 = n1
                ; s = s1 ; s2 = s1
                ; ts = ts1 ; ts1 = ts2
                \<rbrakk> \<Longrightarrow> K \<turnstile> TCon n ts s \<leftarrow> TCon n1 ts1 s1 \<sqinter> TCon n2 ts2 s2"
| glb_tfun   : "\<lbrakk> K \<turnstile> t \<leftarrow> t1 \<squnion> t2
                ; K \<turnstile> u \<leftarrow> u1 \<sqinter> u2
                \<rbrakk> \<Longrightarrow> K \<turnstile> TFun t u \<leftarrow> TFun t1 u1 \<sqinter> TFun t2 u2"
| glb_tprim  : "\<lbrakk> p = p1
                ; p2 = p1
                \<rbrakk> \<Longrightarrow> K \<turnstile> TPrim p \<leftarrow> TPrim p1 \<sqinter> TPrim p2"
| glb_trecord: "\<lbrakk> list_all3 (\<lambda>p p1 p2. (K \<turnstile> (fst (snd p)) \<leftarrow> (fst (snd p1)) \<sqinter> (fst (snd p2)))) ts ts1 ts2
                ; list_all3 (\<lambda>p p1 p2. let b = snd (snd p)
                                         ; b1 = snd (snd p1)
                                         ; b2 = snd (snd p2)
                                        in
                                          (if (K \<turnstile> fst (snd p) :\<kappa> {D})
                                          then b \<le> b1 \<and> b \<le> b2
                                          else b = b2 \<and> b1 = b2)) ts ts1 ts2
                ; map fst ts = map fst ts1
                ; map fst ts1 = map fst ts2
                ; s = s1 ; s1 = s2
                \<rbrakk> \<Longrightarrow> K \<turnstile> TRecord ts s \<leftarrow> TRecord ts1 s1 \<sqinter> TRecord ts2 s2"
| glb_tprod  : "\<lbrakk> K \<turnstile> t \<leftarrow> t1 \<sqinter> t2
                ; K \<turnstile> u \<leftarrow> u1 \<sqinter> u2
                \<rbrakk> \<Longrightarrow> K \<turnstile> TProduct t u \<leftarrow> TProduct t1 u1 \<sqinter> TProduct t2 u2"
| glb_tsum   : "\<lbrakk> list_all3 (\<lambda>p p1 p2. (K \<turnstile> (fst (snd p)) \<leftarrow> (fst (snd p1)) \<sqinter> (fst (snd p2)))) ts ts1 ts2
                ; list_all3 (\<lambda>p p1 p2. snd (snd p) = inf (snd (snd p1)) (snd (snd p2))) ts ts1 ts2
                ; map fst ts = map fst ts1
                ; map fst ts1 = map fst ts2
                \<rbrakk> \<Longrightarrow> K \<turnstile> TSum ts \<leftarrow> TSum ts1 \<sqinter> TSum ts2"
| glb_tunit  : "K \<turnstile> TUnit \<leftarrow> TUnit \<sqinter> TUnit"

lemma type_lub_type_glb_idem:
  assumes "K \<turnstile> t wellformed"
  shows
    "K \<turnstile> t \<leftarrow> t \<squnion> t"
    "K \<turnstile> t \<leftarrow> t \<sqinter> t"
  using assms
proof (induct t)
  case (TSum ts)
  moreover assume ts_wellformed: "K \<turnstile> TSum ts wellformed"
  ultimately show
    "K \<turnstile> TSum ts \<leftarrow> TSum ts \<squnion> TSum ts"
    "K \<turnstile> TSum ts \<leftarrow> TSum ts \<sqinter> TSum ts"
    by (fastforce simp add: list_all3_same list_all_iff intro!: type_lub_type_glb.intros)+
next
  case (TRecord ts s)
  moreover assume ts_wellformed: "K \<turnstile> TRecord ts s wellformed"
  ultimately show
  "K \<turnstile> TRecord ts s \<leftarrow> TRecord ts s \<squnion> TRecord ts s"
  "K \<turnstile> TRecord ts s \<leftarrow> TRecord ts s \<sqinter> TRecord ts s"
  proof -
    have tWellformed: "\<And>i. i < length ts \<Longrightarrow> K \<turnstile> fst (snd (ts ! i)) wellformed"
      by (metis nth_mem prod.collapse ts_wellformed wellformed_record_wellformed_elem)
    show "K \<turnstile> TRecord ts s \<leftarrow> TRecord ts s \<squnion> TRecord ts s"
    proof (rule_tac lub_trecord)
      show "list_all3 (\<lambda>p p1 p2. K \<turnstile> fst (snd p) \<leftarrow> fst (snd p1) \<squnion> fst (snd p2)) ts ts ts"
        using TRecord.hyps
        by (metis (no_types, lifting) fsts.intros in_set_conv_nth list_all3_same snds.intros tWellformed)
    qed (simp add: list_all3_same)+
    show "K \<turnstile> TRecord ts s \<leftarrow> TRecord ts s \<sqinter> TRecord ts s"
    proof (rule_tac glb_trecord)
      show "list_all3 (\<lambda>p p1 p2. K \<turnstile> fst (snd p) \<leftarrow> fst (snd p1) \<sqinter> fst (snd p2)) ts ts ts"
        using TRecord.hyps
        by (metis (no_types, lifting) fsts.intros in_set_conv_nth list_all3_same snds.intros tWellformed)
    qed (simp add: list_all3_same)+
  qed
qed (fastforce intro!: type_lub_type_glb.intros)+

lemma type_lub_type_glb_commut:
  shows
  "K \<turnstile> c \<leftarrow> a \<squnion> b \<Longrightarrow> K \<turnstile> c \<leftarrow> b \<squnion> a"
  "K \<turnstile> c \<leftarrow> a \<sqinter> b \<Longrightarrow> K \<turnstile> c \<leftarrow> b \<sqinter> a"
proof (induct rule: type_lub_type_glb.inducts)
  case (lub_trecord K ts ts1 ts2 s s1 s2)
  then show ?case
  proof (rule_tac type_lub_type_glb.lub_trecord)
    show "list_all3 (\<lambda>p p1 p2. K \<turnstile> fst (snd p) \<leftarrow> fst (snd p1) \<squnion> fst (snd p2)) ts ts2 ts1"
      using list_all3_comm2 list_all3_mono lub_trecord.hyps by fastforce
    show "list_all3 (\<lambda>p p1 p2. let b = snd (snd p); b1 = snd (snd p1); b2 = snd (snd p2) in
          (if K \<turnstile> fst (snd p1) :\<kappa> {D} then b1 \<le> b else b1 = b) \<and>
          (if K \<turnstile> fst (snd p2) :\<kappa> {D} then b2 \<le> b else b2 = b)) ts ts2 ts1"
      using lub_trecord.hyps
      by (clarsimp simp add: list_all3_conv_all_nth, meson)
  qed (simp)+
next
  case (lub_tsum K ts ts1 ts2)
  then show ?case
    by (simp add: list_all3_conv_all_nth sup_commute type_lub_type_glb.lub_tsum)
next
  case (glb_trecord K ts ts1 ts2 s s1 s2)
  then show ?case
  proof (rule_tac type_lub_type_glb.glb_trecord)
    show "list_all3 (\<lambda>p p1 p2. K \<turnstile> fst (snd p) \<leftarrow> fst (snd p1) \<sqinter> fst (snd p2)) ts ts2 ts1"
      using glb_trecord.hyps list_all3_comm2 list_all3_mono by fastforce
    show "list_all3 (\<lambda>p p1 p2.  let b = snd (snd p); b1 = snd (snd p1); b2 = snd (snd p2) in
          if K \<turnstile> fst (snd p) :\<kappa> {D} then b \<le> b1 \<and> b \<le> b2
          else b = b2 \<and> b1 = b2) ts ts2 ts1"
      using glb_trecord.hyps
      apply (clarsimp simp add: list_all3_conv_all_nth)
      by metis
  qed (simp)+
next
  case (glb_tsum K ts ts1 ts2)
  then show ?case
    by (simp add: inf_sup_aci(1) list_all3_conv_all_nth type_lub_type_glb.glb_tsum)
qed (fastforce intro!: type_lub_type_glb.intros)+

lemma type_lub_type_glb_wellformed:
  assumes
    "K \<turnstile> t1 wellformed"
    "K \<turnstile> t2 wellformed"
  shows
    "K \<turnstile> t \<leftarrow> t1 \<squnion> t2 \<Longrightarrow> K \<turnstile> t wellformed"
    "K \<turnstile> t \<leftarrow> t1 \<sqinter> t2 \<Longrightarrow> K \<turnstile> t wellformed"
  using assms
proof (induct rule: type_lub_type_glb.inducts)
qed (auto simp add: list_all_length list_all3_conv_all_nth)

lemma type_lub_type_glb_wellformed_produce_wellformed:
  "K \<turnstile> c \<leftarrow> a \<squnion> b \<Longrightarrow> K \<turnstile> c wellformed \<Longrightarrow> (K \<turnstile> a wellformed) \<and> (K \<turnstile> b wellformed)"
  "K \<turnstile> c \<leftarrow> a \<sqinter> b \<Longrightarrow> K \<turnstile> c wellformed \<Longrightarrow> (K \<turnstile> a wellformed) \<and> (K \<turnstile> b wellformed)"
proof (induct rule: type_lub_type_glb.inducts)
qed (auto simp add: list_all3_conv_all_nth list_all_length)

lemma type_glb_drop_produce_drop:
  shows
  "K \<turnstile> c \<leftarrow> a \<squnion> b \<Longrightarrow> K \<turnstile> c :\<kappa> {D} \<Longrightarrow> K \<turnstile> a :\<kappa> {D} \<and> K \<turnstile> b :\<kappa> {D}"
  "K \<turnstile> c \<leftarrow> a \<sqinter> b \<Longrightarrow> K \<turnstile> a :\<kappa> {D} \<Longrightarrow> K \<turnstile> b :\<kappa> {D} \<Longrightarrow> K \<turnstile> c :\<kappa> {D}"
proof (induct rule: type_lub_type_glb.inducts)
  case (lub_tfun K t t1 t2 u u1 u2)
  then show ?case
    using kinding_simps(4) type_lub_type_glb_wellformed_produce_wellformed by auto
next
  case (lub_trecord K ts ts1 ts2 s s1 s2)
  then show ?case
  proof -
    have "K \<turnstile> TRecord ts s wellformed"
      using kinding_def lub_trecord.prems by blast
    then have ts1ts2Wellformed:
      "K \<turnstile> TRecord ts1 s wellformed"
      "K \<turnstile> TRecord ts2 s wellformed"
      using lub_trecord.hyps type_lub_type_glb_wellformed_produce_wellformed
      by (metis (mono_tags, lifting) list_all3_conv_all_nth list_all_length type_wellformed.simps(8) type_wellformed_pretty_def)+
    have "K \<turnstile> TRecord ts1 s1 :\<kappa> {D}"
      using lub_trecord
    proof (clarsimp simp: kinding_record_conv_all_nth kinding_simps)
      fix i :: nat
      assume tsLength: "i < length ts1"
      let ?t1 = "fst (snd (ts1 ! i))"
      let ?b1 = "snd (snd (ts1 ! i))"
      show "case ?b1 of Taken \<Rightarrow> K \<turnstile> ?t1 wellformed | Present \<Rightarrow> K \<turnstile> ?t1 :\<kappa> {D}"
      proof (cases ?b1)
        case Taken
        moreover have "length ts = length ts1"
          using lub_trecord.hyps
          by (metis length_map)
        ultimately show ?thesis
          using  ts1ts2Wellformed tsLength
          by (auto simp add: list_all_length)
      next
        case Present
        then show ?thesis
          using lub_trecord.hyps lub_trecord.prems tsLength
          apply (clarsimp
              simp add: kinding_simps list_all3_conv_all_nth kinding_record_conv_all_nth
              split: record_state.splits)
          apply metis
          done
      qed
    qed
    moreover have "K \<turnstile> TRecord ts2 s2 :\<kappa> {D}"
      using lub_trecord
    proof (clarsimp simp: kinding_record_conv_all_nth kinding_simps)
      fix i :: nat
      assume tsLength: "i < length ts2"
      let ?t2 = "fst (snd (ts2 ! i))"
      let ?b2 = "snd (snd (ts2 ! i))"
      show "case ?b2 of Taken \<Rightarrow> K \<turnstile> ?t2 wellformed | Present \<Rightarrow> K \<turnstile> ?t2 :\<kappa> {D}"
      proof (cases ?b2)
        case Taken
        moreover have "length ts = length ts2"
          using lub_trecord.hyps
          by (metis length_map)
        ultimately show ?thesis
          using  ts1ts2Wellformed tsLength
          by (auto simp add: list_all_length)
      next
        case Present
        then show ?thesis
          using lub_trecord.hyps lub_trecord.prems tsLength
          apply (clarsimp
              simp add: kinding_simps list_all3_conv_all_nth kinding_record_conv_all_nth
              split: record_state.splits)
          apply metis
          done
      qed
    qed
    ultimately show ?thesis
      by blast
  qed
next
  case (lub_tsum K ts ts1 ts2)
  then show ?case
  proof -
    have "K \<turnstile> TSum ts wellformed"
      using kinding_def lub_tsum.prems by blast
    then have ts1ts2Wellformed:
      "K \<turnstile> TSum ts1 wellformed"
      "K \<turnstile> TSum ts2 wellformed"
      using lub_tsum.hyps type_lub_type_glb_wellformed_produce_wellformed
      by (metis (mono_tags, lifting) list_all3_conv_all_nth list_all_length type_wellformed.simps(6) type_wellformed_pretty_def)+
    have "K \<turnstile> TSum ts1 :\<kappa> {D}"
      using lub_tsum
    proof (clarsimp simp: kinding_variant_conv_all_nth kinding_simps)
      fix i :: nat
      assume tsLength: "i < length ts1"
      let ?t1 = "fst (snd (ts1 ! i))"
      let ?b1 = "snd (snd (ts1 ! i))"
      show "case ?b1 of Checked \<Rightarrow> K \<turnstile> ?t1 wellformed | Unchecked \<Rightarrow> K \<turnstile> ?t1 :\<kappa> {D}"
      proof (cases ?b1)
        case Checked
        moreover have "length ts = length ts1"
          using lub_tsum.hyps
          by (metis length_map)
        ultimately show ?thesis
          using  ts1ts2Wellformed tsLength
          by (auto simp add: list_all_length)
      next
        case Unchecked
        then show ?thesis
          using lub_tsum.hyps lub_tsum.prems tsLength
          apply (clarsimp
              simp add: kinding_simps list_all3_conv_all_nth kinding_variant_conv_all_nth
              split: variant_state.splits)
          done
      qed
    qed
    moreover have "K \<turnstile> TSum ts2 :\<kappa> {D}"
      using lub_tsum
    proof (clarsimp simp: kinding_variant_conv_all_nth kinding_simps)
      fix i :: nat
      assume tsLength: "i < length ts2"
      let ?t2 = "fst (snd (ts2 ! i))"
      let ?b2 = "snd (snd (ts2 ! i))"
      show "case ?b2 of Checked \<Rightarrow> K \<turnstile> ?t2 wellformed | Unchecked \<Rightarrow> K \<turnstile> ?t2 :\<kappa> {D}"
      proof (cases ?b2)
        case Checked
        moreover have "length ts = length ts2"
          using lub_tsum.hyps
          by (metis length_map)
        ultimately show ?thesis
          using  ts1ts2Wellformed tsLength
          by (auto simp add: list_all_length)
      next
        case Unchecked
        then show ?thesis
          using lub_tsum.hyps lub_tsum.prems tsLength
          apply (clarsimp
              simp add: kinding_simps list_all3_conv_all_nth kinding_variant_conv_all_nth sup_commute
              split: variant_state.splits)
          done
      qed
    qed
    ultimately show ?thesis
      by blast
  qed
next
  case (glb_tcon n n1 n2 s s1 s2 ts ts1 ts2 K)
  then show ?case
    by (clarsimp simp add: list_all3_conv_all_nth kinding_simps)
next
  case (glb_tfun K t t1 t2 u u1 u2)
  then show ?case
    by (meson kinding_simps type_lub_type_glb_wellformed)
next
  case (glb_trecord K ts ts1 ts2 s s1 s2)
  then show ?case
    using glb_trecord
  proof (clarsimp simp: kinding_record_conv_all_nth kinding_simps)
    have
      "(K \<turnstile> TRecord ts1 s1 wellformed)"
      "(K \<turnstile> TRecord ts2 s2 wellformed)"
      using glb_trecord.prems kinding_to_wellformedD(1) by blast+
    then have tsWellformed: "K \<turnstile> TRecord ts s wellformed"
      using glb_trecord.hyps
      apply (clarsimp simp add: list_all3_conv_all_nth)
      using type_lub_type_glb_wellformed
      by (metis (no_types, lifting) list_all_length type_wellformed_pretty_def)
    {
      fix i :: nat
      assume tsLength: "i < length ts"
      let ?t = "fst (snd (ts ! i))"
      let ?b = "snd (snd (ts ! i))"
      show "case ?b of Taken \<Rightarrow> K \<turnstile> ?t wellformed | Present \<Rightarrow> K \<turnstile> ?t :\<kappa> {D}"
      proof (cases ?b)
        case Taken
        then show ?thesis
          using tsWellformed tsLength
          apply (simp add: list_all_length)
          done
      next
        case Present
        then show ?thesis
          using glb_trecord.hyps glb_trecord.prems tsLength
          apply (clarsimp
              simp add: kinding_simps list_all3_conv_all_nth kinding_record_conv_all_nth sup_commute
              split: record_state.splits)
          apply metis
          done
      qed
    }
  qed
next
  case (glb_tsum K ts ts1 ts2)
  then show ?case
   using glb_tsum
  proof (clarsimp simp: kinding_variant_conv_all_nth kinding_simps)
    have
      "(K \<turnstile> TSum ts1 wellformed)"
      "(K \<turnstile> TSum ts2 wellformed)"
      using glb_tsum.prems kinding_to_wellformedD(1) by blast+
    then have tsWellformed: "K \<turnstile> TSum ts wellformed"
      using glb_tsum.hyps
      apply (clarsimp simp add: list_all3_conv_all_nth)
      using type_lub_type_glb_wellformed
      by (metis (no_types, lifting) list_all_length type_wellformed_pretty_def)
    {
      fix i :: nat
      assume tsLength: "i < length ts"
      let ?t = "fst (snd (ts ! i))"
      let ?b = "snd (snd (ts ! i))"
      show "case ?b of Checked \<Rightarrow> K \<turnstile> ?t wellformed | Unchecked \<Rightarrow> K \<turnstile> ?t :\<kappa> {D}"
      proof (cases ?b)
        case Checked
        then show ?thesis
          using tsWellformed tsLength
          apply (simp add: list_all_length)
          done
      next
        case Unchecked
        then show ?thesis
          using glb_tsum.hyps glb_tsum.prems tsLength
          apply (clarsimp
              simp add: kinding_simps list_all3_conv_all_nth kinding_variant_conv_all_nth
              split: variant_state.splits)
          apply (blast elim: inf_variant_state.elims)
          done
      qed
    }
  qed
qed (auto simp add: kinding_simps)

lemma type_lub_type_glb_absorb:
  shows
    "K \<turnstile> c \<leftarrow> a \<squnion> b \<Longrightarrow> K \<turnstile> a \<leftarrow> a \<sqinter> c"
    "K \<turnstile> c \<leftarrow> a \<sqinter> b \<Longrightarrow> K \<turnstile> a \<leftarrow> a \<squnion> c"
proof (induct rule: type_lub_type_glb.inducts)
qed (force intro!: type_lub_type_glb.intros simp add: list_all3_conv_all_nth Let_def)+

lemma type_lub_type_glb_order_correct: "K \<turnstile> a \<leftarrow> a \<squnion> b \<longleftrightarrow> K \<turnstile> b \<leftarrow> a \<sqinter> b"
  by (auto intro: type_lub_type_glb_absorb type_lub_type_glb_commut)

lemma glb_lub_subtyping_order_correct:
  shows
    "K \<turnstile> c \<leftarrow> a \<squnion> b \<Longrightarrow> (K \<turnstile> a \<sqsubseteq> c) \<and> (K \<turnstile> b \<sqsubseteq> c)"
    "K \<turnstile> c \<leftarrow> a \<sqinter> b \<Longrightarrow> (K \<turnstile> c \<sqsubseteq> a) \<and> (K \<turnstile> c \<sqsubseteq> b)"
proof (induct rule: type_lub_type_glb.inducts)
  case (lub_trecord K ts ts1 ts2 s s1 s2)
  then show ?case
  proof -
    have "K \<turnstile> TRecord ts1 s1 \<sqsubseteq> TRecord ts s"
    proof (rule subty_trecord)
      show "list_all2 (\<lambda>p1 p2. K \<turnstile> fst (snd p1) \<sqsubseteq> fst (snd p2)) ts1 ts"
        using lub_trecord.hyps
        by (clarsimp simp add: list_all2_conv_all_nth list_all3_conv_all_nth)
      show "list_all2 (record_kind_subty K) ts1 ts"
        using lub_trecord.hyps le_neq_trans
        apply (clarsimp simp add: list_all2_conv_all_nth list_all3_conv_all_nth)
        by fastforce
    qed (simp add: lub_trecord.hyps)+
    moreover have "K \<turnstile> TRecord ts2 s2 \<sqsubseteq> TRecord ts s"
    proof (rule subty_trecord)
      show "list_all2 (\<lambda>p1 p2. K \<turnstile> fst (snd p1) \<sqsubseteq> fst (snd p2)) ts2 ts"
        using lub_trecord.hyps
        by (clarsimp simp add: list_all2_conv_all_nth list_all3_conv_all_nth)
      show "list_all2 (record_kind_subty K) ts2 ts"
        using lub_trecord.hyps le_neq_trans
        apply (clarsimp simp add: list_all2_conv_all_nth list_all3_conv_all_nth)
        by fastforce
    qed (simp add: lub_trecord.hyps)+
    ultimately show ?thesis
      by simp
  qed
next
  case (glb_trecord K ts ts1 ts2 s s1 s2)
  then show ?case
  proof -
    have "K \<turnstile> TRecord ts s \<sqsubseteq> TRecord ts1 s1"
    proof (rule subty_trecord)
      show "list_all2 (\<lambda>p1 p2. K \<turnstile> fst (snd p1) \<sqsubseteq> fst (snd p2)) ts ts1"
        using glb_trecord.hyps
        by (clarsimp simp add: list_all2_conv_all_nth list_all3_conv_all_nth)
      show "list_all2 (record_kind_subty K) ts ts1"
        using glb_trecord.hyps
        apply (clarsimp simp add: list_all2_conv_all_nth list_all3_conv_all_nth)
        by (metis (no_types) le_less)
    qed (simp add: glb_trecord.hyps)+
    moreover have "K \<turnstile> TRecord ts s \<sqsubseteq> TRecord ts2 s2"
    proof (rule subty_trecord)
      show "list_all2 (\<lambda>p1 p2. K \<turnstile> fst (snd p1) \<sqsubseteq> fst (snd p2)) ts ts2"
        using glb_trecord.hyps
        by (clarsimp simp add: list_all2_conv_all_nth list_all3_conv_all_nth)
      show "list_all2 (record_kind_subty K) ts ts2"
        using glb_trecord.hyps
        apply (clarsimp simp add: list_all2_conv_all_nth list_all3_conv_all_nth)
        by (meson le_less)
    qed (simp add: glb_trecord.hyps)+
    ultimately show ?thesis
      by simp
  qed
qed (auto simp add: subtyping_simps list_all3_conv_all_nth list_all2_conv_all_nth)

lemma type_lub_type_glb_to_subtyping:
  shows
    "K \<turnstile> a \<leftarrow> a \<squnion> b \<Longrightarrow> K \<turnstile> b \<sqsubseteq> a"
    "K \<turnstile> b \<leftarrow> a \<sqinter> b \<Longrightarrow> K \<turnstile> b \<sqsubseteq> a"
  using glb_lub_subtyping_order_correct
  by fast+

lemma subtyping_to_type_lub:
  shows
    "K \<turnstile> b \<sqsubseteq> a \<Longrightarrow> K \<turnstile> a \<leftarrow> a \<squnion> b"
proof (induct rule: subtyping.inducts)
  case (subty_tfun K t2 t1 u1 u2)
  then show ?case
    by (simp add: glb_tfun type_lub_type_glb_commut(1) type_lub_type_glb_order_correct)
next
  case (subty_trecord K ts1 ts2 s1 s2)
  then show ?case
  proof (rule_tac type_lub_type_glb.lub_trecord)
  qed (clarsimp simp add: list_all2_conv_all_nth list_all3_conv_all_nth, auto)+
next
  case (subty_tsum K ts1 ts2)
  then show ?case
    by (simp add: list_all2_conv_all_nth list_all3_conv_all_nth lub_tsum sup.absorb_iff1)
qed (auto intro: type_lub_type_glb.intros)

lemma subtyping_to_type_glb:
  shows
    "K \<turnstile> b \<sqsubseteq> a \<Longrightarrow> K \<turnstile> b \<leftarrow> a \<sqinter> b"
proof (induct rule: subtyping.induct)
case (subty_tfun K t2 t1 u1 u2)
  then show ?case
    by (simp add: subty_tfun.hyps(2) glb_tfun subtyping_to_type_lub type_lub_type_glb_commut(2))
next
  case (subty_trecord K ts1 ts2 s1 s2)
  then show ?case
  proof (rule_tac type_lub_type_glb.glb_trecord)
  qed (clarsimp simp add: list_all2_conv_all_nth list_all3_conv_all_nth, auto)+
next
  case (subty_tsum K ts1 ts2)
  then show ?case
    by (simp add: glb_tsum inf.absorb2 list_all2_conv_all_nth list_all3_conv_all_nth)
qed (auto intro: type_lub_type_glb.intros)

theorem type_glb_type_lub_subtyping_equivalent:
  shows
    "K \<turnstile> a \<leftarrow> a \<squnion> b \<longleftrightarrow> K \<turnstile> b \<sqsubseteq> a"
    "K \<turnstile> b \<leftarrow> a \<sqinter> b \<longleftrightarrow> K \<turnstile> b \<sqsubseteq> a"
  using subtyping_to_type_lub type_lub_type_glb_to_subtyping subtyping_to_type_glb by blast+

end


theory StackFlattener
imports Main
begin

primrec stack_to_mem :: "int list \<Rightarrow> (nat \<Rightarrow> int) \<Rightarrow> nat \<Rightarrow> int" where
  "stack_to_mem [] \<mu> k = (if k = 0 then 0 else \<mu> k)"
| "stack_to_mem (i # is) \<mu> k = (
    if k = 0 then 1 + int (length is)
    else if k = Suc (length is) then i
    else stack_to_mem is \<mu> k)"

lemma stack_same: "k > 0 \<Longrightarrow> k \<le> length \<sigma> \<Longrightarrow> stack_to_mem \<sigma> \<mu> k = stack_to_mem \<sigma> \<mu>' k"
  by (induction \<sigma>) simp_all

lemma [simp]: "k > length \<sigma> \<Longrightarrow> stack_to_mem \<sigma> \<mu> k = \<mu> k"
  by (induction \<sigma>) simp_all

lemma [simp]: "(stack_to_mem (a # \<sigma>) \<mu>)(nat (1 + int (length \<sigma>)) := b) = stack_to_mem (b # \<sigma>) \<mu>"
  proof
    fix x
    show "((stack_to_mem (a # \<sigma>) \<mu>)(nat (1 + int (length \<sigma>)) := b)) x = stack_to_mem (b # \<sigma>) \<mu> x"
      by auto
  qed

lemma [simp]: "(stack_to_mem (i1 # \<sigma>) \<mu>)(0 := int (length \<sigma>)) =
    stack_to_mem \<sigma> (stack_to_mem (i1 # \<sigma>) \<mu>)"
  proof
    fix x
    show "((stack_to_mem (i1 # \<sigma>) \<mu>)(0 := int (length \<sigma>))) x =
        stack_to_mem \<sigma> (stack_to_mem (i1 # \<sigma>) \<mu>) x"
      by (cases "x > length \<sigma>") (simp_all add: stack_same)
  qed

lemma [simp]: "(stack_to_mem (i1 # i2 # \<sigma>) \<mu>)(0 := 1 + int (length \<sigma>)) =
    stack_to_mem (i2 # \<sigma>) (stack_to_mem (i1 # i2 # \<sigma>) \<mu>)"
  proof
    fix x
    show "((stack_to_mem (i1 # i2 # \<sigma>) \<mu>)(0 := 1 + int (length \<sigma>))) x =
        stack_to_mem (i2 # \<sigma>) (stack_to_mem (i1 # i2 # \<sigma>) \<mu>) x"
      by (cases "x > length \<sigma>") (simp_all add: stack_same)
  qed

lemma [simp]: "(stack_to_mem \<sigma> \<mu>)(0 := int (length \<sigma>) + 1, nat (int (length \<sigma>) + 1) := d) =
    stack_to_mem (d # \<sigma>) \<mu>"
  proof
    fix x
    show "((stack_to_mem \<sigma> \<mu>)(0 := int (length \<sigma>) + 1, nat (int (length \<sigma>) + 1) := d)) x =
        stack_to_mem (d # \<sigma>) \<mu> x" by auto
  qed

lemma [simp]: "n < length \<sigma> \<Longrightarrow> stack_to_mem \<sigma> \<mu> (nat (int (length \<sigma>) - int n)) = \<sigma> ! n"
  proof (induction \<sigma> arbitrary: n)
  case Nil
    thus ?case by simp
  next case Cons
    thus ?case by (induction n) fastforce+
  qed

lemma [simp]: "n < length \<sigma> \<Longrightarrow> (stack_to_mem \<sigma> \<mu>)(nat (int (length \<sigma>) - int n) := d) =
    stack_to_mem (\<sigma>[n := d]) \<mu>"
  proof
    fix x
    assume "n < length \<sigma>"
    thus "((stack_to_mem \<sigma> \<mu>)(nat (int (length \<sigma>) - int n) := d)) x = stack_to_mem (\<sigma>[n := d]) \<mu> x"
      proof (induction \<sigma> arbitrary: n)
      case Nil
        thus ?case by simp
      next case Cons
        thus ?case by (induction n) fastforce+
      qed
  qed

end


theory Sail2_values_lemmas
  imports Sail2_values
begin

lemma while_domI:
  fixes V :: "'vars \<Rightarrow> nat"
  assumes "\<And>vars. cond vars \<Longrightarrow> V (body vars) < V vars"
  shows "while_dom (vars, cond, body)"
  by (induction vars rule: measure_induct_rule[where f = V])
     (use assms in \<open>auto intro: while.domintros\<close>)

lemma nat_of_int_nat_simps[simp]: "nat_of_int = nat" by (auto simp: nat_of_int_def)

termination reverse_endianness_list by (lexicographic_order simp add: drop_list_def)
declare reverse_endianness_list.simps[simp del]
declare take_list_def[simp]
declare drop_list_def[simp]

function take_chunks :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list list" where
  "take_chunks n [] = []"
| "take_chunks 0 xs = []"
| "take_chunks n xs = take n xs # take_chunks n (drop n xs)" if "n > 0" and "xs \<noteq> []"
  by auto blast
termination by lexicographic_order

lemma take_chunks_length_leq_n: "length xs \<le> n \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> take_chunks n xs = [xs]"
  by (cases n) auto

lemma take_chunks_append: "n dvd length a \<Longrightarrow> take_chunks n (a @ b) = take_chunks n a @ take_chunks n b"
  by (induction n a rule: take_chunks.induct) (auto simp: dvd_imp_le)

lemma Suc8_plus8: "Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc x))))))) = 8 + x"
  by auto

lemma byte_chunks_take_chunks_8:
  assumes "8 dvd length xs"
  shows "byte_chunks xs = Some (take_chunks 8 xs)"
proof -
  have Suc8_plus8: "Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc x))))))) = 8 + x" for x
    by auto
  from assms show ?thesis
    by (induction xs rule: byte_chunks.induct) (auto simp: Suc8_plus8 nat_dvd_not_less)
qed

lemma reverse_endianness_list_rev_take_chunks:
  "reverse_endianness_list bits = List.concat (rev (take_chunks 8 bits))"
  by (induction "8 :: nat" bits rule: take_chunks.induct)
     (auto simp: reverse_endianness_list.simps)

lemma reverse_endianness_list_simps:
  "length bits \<le> 8 \<Longrightarrow> reverse_endianness_list bits = bits"
  "length bits > 8 \<Longrightarrow> reverse_endianness_list bits = reverse_endianness_list (drop 8 bits) @ take 8 bits"
  by (cases bits; auto simp: reverse_endianness_list_rev_take_chunks)+

lemma reverse_endianness_list_append:
  assumes "8 dvd length a"
  shows "reverse_endianness_list (a @ b) = reverse_endianness_list b @ reverse_endianness_list a"
  using assms by (auto simp: reverse_endianness_list_rev_take_chunks take_chunks_append)

lemma length_reverse_endianness_list[simp]:
  "length (reverse_endianness_list l) = length l"
  by (induction l rule: reverse_endianness_list.induct) (auto simp: reverse_endianness_list.simps)

lemma reverse_endianness_list_take_8[simp]:
  "reverse_endianness_list (take 8 bits) = take 8 bits"
  by (auto simp: reverse_endianness_list_simps)

lemma reverse_reverse_endianness_list[simp]:
  assumes "8 dvd length l"
  shows "reverse_endianness_list (reverse_endianness_list l) = l"
proof (use assms in \<open>induction l rule: reverse_endianness_list.induct[case_names Step]\<close>)
  case (Step bits)
  then show ?case
    by (auto simp: reverse_endianness_list.simps[of bits] reverse_endianness_list_append)
qed

declare repeat.simps[simp del]

lemma length_repeat[simp]: "length (repeat xs n) = nat n * length xs"
proof (induction xs n rule: repeat.induct[case_names Step])
  case (Step xs n)
  then show ?case unfolding repeat.simps[of xs n]
    by (auto simp del: mult_Suc simp: mult_Suc[symmetric])
qed

lemma nth_repeat:
  assumes "i < nat n * length xs"
  shows "repeat xs n ! i = xs ! (i mod length xs)"
proof (use assms in \<open>induction xs n arbitrary: i rule: repeat.induct[case_names Step]\<close>)
  case (Step xs n i)
  show ?case
    using Step.prems Step.IH[of "i - length xs"]
    unfolding repeat.simps[of xs n]
    by (auto simp: nth_append mod_geq[symmetric] nat_diff_distrib diff_mult_distrib)
qed

termination index_list
  by (relation "measure (\<lambda>(i, j, step). nat ((j - i + step) * sgn step))") auto

lemma index_list_Zero[simp]: "index_list i j 0 = []"
  by auto

lemma index_list_simps:
  "0 < step \<Longrightarrow> from \<le> to \<Longrightarrow> index_list from to step = from # index_list (from + step) to step"
  "0 < step \<Longrightarrow> from > to \<Longrightarrow> index_list from to step = []"
  "0 > step \<Longrightarrow> from \<ge> to \<Longrightarrow> index_list from to step = from # index_list (from + step) to step"
  "0 > step \<Longrightarrow> from < to \<Longrightarrow> index_list from to step = []"
  by auto

lemma index_list_step1_upto[simp]: "index_list i j 1 = [i..j]"
  by (induction i j "1 :: int" rule: index_list.induct)
     (auto simp: index_list_simps upto.simps)

lemma length_upto[simp]: "i \<le> j \<Longrightarrow> length [i..j] = nat (j - i + 1)"
  by (induction i j rule: upto.induct) (auto simp: upto.simps)

lemma nth_upto[simp]: "i + int n \<le> j \<Longrightarrow> [i..j] ! n = i + int n"
  by (induction i j arbitrary: n rule: upto.induct)
     (auto simp: upto.simps nth_Cons split: nat.splits)

declare index_list.simps[simp del]

lemma index_list_singleton[simp]: "n \<noteq> 0 \<Longrightarrow> index_list i i n = [i]"
  by (auto simp: index_list.simps[of i i n] index_list.simps[of "i + n" i n])

lemma genlist_add_upt[simp]: "genlist ((+) start) len = [start..<start + len]"
  by (auto simp: genlist_def map_add_upt add.commute cong: map_cong)

lemma just_list_map_Some[simp]: "just_list (map Some v) = Some v" by (induction v) auto

lemma just_list_None_iff[simp]: "just_list xs = None \<longleftrightarrow> None \<in> set xs"
  by (induction xs) (auto split: option.splits)

lemma just_list_None_member_None: "None \<in> set xs \<Longrightarrow> just_list xs = None"
  by auto

lemma just_list_Some_iff[simp]: "just_list xs = Some ys \<longleftrightarrow> xs = map Some ys"
  by (induction xs arbitrary: ys) (auto split: option.splits)

lemma just_list_cases:
  assumes "just_list xs = y"
  obtains (None) "None \<in> set xs" and "y = None"
        | (Some) ys where "xs = map Some ys" and "y = Some ys"
  using assms by (cases y) auto

lemma repeat_singleton_replicate[simp]:
  "repeat [x] n = replicate (nat n) x"
proof (induction n)
  case (nonneg n)
  have "nat (1 + int m) = Suc m" for m by auto
  then show ?case by (induction n) (auto simp: repeat.simps)
next
  case (neg n)
  then show ?case by (auto simp: repeat.simps)
qed

lemma and_bit_B1[simp]: "and_bit B1 b = b"
  by (cases b) auto

lemma and_bit_idem[simp]: "and_bit b b = b"
  by (cases b) auto

lemma and_bit_eq_iff:
  "and_bit b b' = B0 \<longleftrightarrow> (b = B0 \<or> b' = B0)"
  "and_bit b b' = BU \<longleftrightarrow> (b = BU \<or> b' = BU) \<and> b \<noteq> B0 \<and> b' \<noteq> B0"
  "and_bit b b' = B1 \<longleftrightarrow> (b = B1 \<and> b' = B1)"
  by (cases b; cases b'; auto)+

lemma foldl_and_bit_eq_iff:
  shows "foldl and_bit b bs = B0 \<longleftrightarrow> (b = B0 \<or> B0 \<in> set bs)" (is ?B0)
    and "foldl and_bit b bs = B1 \<longleftrightarrow> (b = B1 \<and> set bs \<subseteq> {B1})" (is ?B1)
    and "foldl and_bit b bs = BU \<longleftrightarrow> (b = BU \<or> BU \<in> set bs) \<and> b \<noteq> B0 \<and> B0 \<notin> set bs" (is ?BU)
proof -
  have "?B0 \<and> ?B1 \<and> ?BU"
  proof (induction bs arbitrary: b)
    case (Cons b' bs)
    show ?case using Cons.IH by (cases b; cases b') auto
  qed auto
  then show ?B0 and ?B1 and ?BU by auto
qed

lemma bool_of_bitU_simps[simp]:
  "bool_of_bitU B0 = Some False"
  "bool_of_bitU B1 = Some True"
  "bool_of_bitU BU = None"
  by (auto simp: bool_of_bitU_def)

lemma bitops_bitU_of_bool[simp]:
  "and_bit (bitU_of_bool x) (bitU_of_bool y) = bitU_of_bool (x \<and> y)"
  "or_bit (bitU_of_bool x) (bitU_of_bool y) = bitU_of_bool (x \<or> y)"
  "xor_bit (bitU_of_bool x) (bitU_of_bool y) = bitU_of_bool ((x \<or> y) \<and> \<not>(x \<and> y))"
  "not_bit (bitU_of_bool x) = bitU_of_bool (\<not>x)"
  "not_bit \<circ> bitU_of_bool = bitU_of_bool \<circ> Not"
  by (auto simp: bitU_of_bool_def not_bit_def)

lemma image_bitU_of_bool_B0_B1: "bitU_of_bool ` bs \<subseteq> {B0, B1}"
  by (auto simp: bitU_of_bool_def split: if_splits)

lemma bool_of_bitU_bitU_of_bool[simp]:
  "bool_of_bitU \<circ> bitU_of_bool = Some"
  "bool_of_bitU \<circ> (bitU_of_bool \<circ> f) = Some \<circ> f"
  "bool_of_bitU (bitU_of_bool x) = Some x"
  by (intro ext, auto simp: bool_of_bitU_def bitU_of_bool_def)+

abbreviation "BC_bitU_list \<equiv> instance_Sail2_values_Bitvector_list_dict instance_Sail2_values_BitU_Sail2_values_bitU_dict"
lemmas BC_bitU_list_def = instance_Sail2_values_Bitvector_list_dict_def instance_Sail2_values_BitU_Sail2_values_bitU_dict_def
abbreviation "BC_mword \<equiv> instance_Sail2_values_Bitvector_Machine_word_mword_dict"
lemmas BC_mword_defs = instance_Sail2_values_Bitvector_Machine_word_mword_dict_def
  access_mword_def access_mword_inc_def access_mword_dec_def
  (*update_mword_def update_mword_inc_def update_mword_dec_def*)
  subrange_list_def subrange_list_inc_def subrange_list_dec_def
  update_subrange_list_def update_subrange_list_inc_def update_subrange_list_dec_def

declare size_itself_int_def[simp]
declare size_itself_def[simp]
declare word_size[simp]

lemma int_of_mword_simps[simp]:
  "int_of_mword False w = uint w"
  "int_of_mword True w = sint w"
  "int_of_bv BC_mword False w = Some (uint w)"
  "int_of_bv BC_mword True w = Some (sint w)"
  by (auto simp: int_of_mword_def int_of_bv_def BC_mword_defs)

lemma BC_mword_simps[simp]:
  "unsigned_method BC_mword a = Some (uint a)"
  "signed_method BC_mword a = Some (sint a)"
  "length_method BC_mword (a :: ('a :: len) word) = int (LENGTH('a))"
  by (auto simp: BC_mword_defs)

lemma of_bits_mword_of_bl[simp]:
  assumes "just_list (map bool_of_bitU bus) = Some bs"
  shows "of_bits_method BC_mword bus = Some (of_bl bs)"
    and "of_bits_failwith BC_mword bus = of_bl bs"
  using assms by (auto simp: BC_mword_defs of_bits_failwith_def maybe_failwith_def)

lemma nat_of_bits_aux_bl_to_bin_aux:
  "nat_of_bools_aux acc bs = nat (bl_to_bin_aux bs (int acc))"
  by (induction acc bs rule: nat_of_bools_aux.induct) auto

lemma nat_of_bits_bl_to_bin[simp]:
  "nat_of_bools bs = nat (bl_to_bin bs)"
  by (auto simp: nat_of_bools_def bl_to_bin_def nat_of_bits_aux_bl_to_bin_aux)

lemma unsigned_bits_of_mword[simp]:
  "unsigned_method BC_bitU_list (bits_of_method BC_mword a) = Some (uint a)"
  by (auto simp: BC_bitU_list_def BC_mword_defs unsigned_of_bits_def unsigned_of_bools_def)

definition mem_bytes_of_word :: "'a::len word \<Rightarrow> bitU list list" where
  "mem_bytes_of_word w = rev (take_chunks 8 (map bitU_of_bool (to_bl w)))"

lemma mem_bytes_of_bits_mem_bytes_of_word[simp]:
  assumes "8 dvd LENGTH('a)"
  shows "mem_bytes_of_bits BC_mword (w :: 'a::len word) = Some (mem_bytes_of_word w)"
  using assms
  by (auto simp: mem_bytes_of_bits_def bytes_of_bits_def BC_mword_defs byte_chunks_take_chunks_8 mem_bytes_of_word_def)

lemma bits_of_bitU_list[simp]:
  "bits_of_method BC_bitU_list v = v"
  "of_bits_method BC_bitU_list v = Some v"
  by (auto simp: BC_bitU_list_def)

lemma subrange_list_inc_drop_take:
  "subrange_list_inc xs i j = drop (nat i) (take (nat (j + 1)) xs)"
  by (auto simp: subrange_list_inc_def split_at_def)

lemma subrange_list_dec_drop_take:
  assumes "i \<ge> 0" and "j \<ge> 0"
  shows "subrange_list_dec xs i j = drop (length xs - nat (i + 1)) (take (length xs - nat j) xs)"
  using assms unfolding subrange_list_dec_def
  by (auto simp: subrange_list_inc_drop_take add.commute diff_diff_add nat_minus_as_int)

lemma update_subrange_list_inc_drop_take:
  assumes "i \<ge> 0" and "j \<ge> i"
  shows "update_subrange_list_inc xs i j xs' = take (nat i) xs @ xs' @ drop (nat (j + 1)) xs"
  using assms unfolding update_subrange_list_inc_def
  by (auto simp: split_at_def min_def)

lemma update_subrange_list_dec_drop_take:
  assumes "j \<ge> 0" and "i \<ge> j"
  shows "update_subrange_list_dec xs i j xs' = take (length xs - nat (i + 1)) xs @ xs' @ drop (length xs - nat j) xs"
  using assms unfolding update_subrange_list_dec_def update_subrange_list_inc_def
  by (auto simp: split_at_def min_def Let_def add.commute diff_diff_add nat_minus_as_int)

declare access_list_inc_def[simp]

lemma access_list_dec_rev_nth:
  assumes "0 \<le> i" and "nat i < length xs"
  shows "access_list_dec xs i = rev xs ! (nat i)"
  using assms
  by (auto simp: access_list_dec_def rev_nth intro!: arg_cong2[where f = List.nth])

lemma access_bv_dec_mword[simp]:
  fixes w :: "('a::len) word"
  assumes "0 \<le> n" and "nat n < LENGTH('a)"
  shows "access_bv_dec BC_mword w n = bitU_of_bool (bit w (nat n))"
  using assms unfolding access_bv_dec_def access_list_def
  by (auto simp: access_list_dec_rev_nth BC_mword_defs rev_map test_bit_bl)

lemma access_list_dec_nth[simp]:
  assumes "0 \<le> i"
  shows "access_list_dec xs i = xs ! (length xs - nat (i + 1))"
  using assms
  by (auto simp: access_list_dec_def add.commute diff_diff_add nat_minus_as_int)

lemma update_list_inc_update[simp]:
  "update_list_inc xs n x = xs[nat n := x]"
  by (auto simp: update_list_inc_def)

lemma update_list_dec_update[simp]:
  "update_list_dec xs n x = xs[length xs - nat (n + 1) := x]"
  by (auto simp: update_list_dec_def add.commute diff_diff_add nat_minus_as_int)

lemma update_list_dec_update_rev:
  "0 \<le> n \<Longrightarrow> nat n < length xs \<Longrightarrow> update_list_dec xs n x = rev ((rev xs)[nat n := x])"
  by (auto simp: update_list_dec_def add.commute diff_diff_add nat_minus_as_int rev_update)

lemma access_list_dec_update_list_dec[simp]:
  "0 \<le> n \<Longrightarrow> nat n < length xs \<Longrightarrow> access_list_dec (update_list_dec xs n x) n = x"
  by (auto simp: access_list_dec_rev_nth update_list_dec_update_rev)

lemma bools_of_nat_aux_simps[simp]:
  "\<And>len. len \<le> 0 \<Longrightarrow> bools_of_nat_aux len x acc = acc"
  "\<And>len. bools_of_nat_aux (int (Suc len)) x acc =
     bools_of_nat_aux (int len) (x div 2) ((if x mod 2 = 1 then True else False) # acc)"
  by auto
declare bools_of_nat_aux.simps[simp del]

lemma bools_of_nat_aux_bin_to_bl_aux:
  "bools_of_nat_aux len n acc = bin_to_bl_aux (nat len) (int n) acc"
proof (cases len)
  case (nonneg len')
  show ?thesis unfolding nonneg
  proof (induction len' arbitrary: n acc)
    case (Suc len'' n acc)
    then show ?case
      using zmod_int[of n 2]
      by (cases "odd n") (auto simp del: of_nat_simps simp add: zdiv_int)
  qed auto
qed auto

lemma bools_of_nat_bin_to_bl[simp]:
  "bools_of_nat len n = bin_to_bl (nat len) (int n)"
  by (auto simp: bools_of_nat_def bools_of_nat_aux_bin_to_bl_aux)

lemma add_one_bool_ignore_overflow_aux_rbl_succ[simp]:
  "add_one_bool_ignore_overflow_aux xs = rbl_succ xs"
  by (induction xs) auto

lemma add_one_bool_ignore_overflow_rbl_succ[simp]:
  "add_one_bool_ignore_overflow xs = rev (rbl_succ (rev xs))"
  unfolding add_one_bool_ignore_overflow_def by auto

lemma map_Not_bin_to_bl:
  "map Not (bin_to_bl_aux len n acc) = bin_to_bl_aux len (-n - 1) (map Not acc)"
proof (induction len arbitrary: n acc)
  case (Suc len n acc)
  moreover have "(- (n div 2) - 1) = ((-n - 1) div 2)" by auto
  moreover have "(n mod 2 = 0) = ((- n - 1) mod 2 = 1)" by presburger
  ultimately show ?case by (auto simp: bin_last_def)
qed auto

lemma bools_of_int_bin_to_bl[simp]:
  "bools_of_int len n = bin_to_bl (nat len) n"
  by (auto simp: bools_of_int_def Let_def map_Not_bin_to_bl rbl_succ[unfolded bin_to_bl_def])

lemmas register_ops_of_simp[simp] = register_ops_of_def[of "register_ref_ext _ _ _ _ _ _"]

definition
  register_read_ok :: "(string \<Rightarrow> ('regval \<Rightarrow> bool) option) \<Rightarrow> string \<Rightarrow> 'regval \<Rightarrow> bool"
  where
  "register_read_ok f nm r = (case f nm of None \<Rightarrow> False | Some P \<Rightarrow> P r)"

lemma option_bind_SomeE:
  assumes "Option.bind x f = Some y"
  obtains z where "x = Some z" and "f z = Some y"
  using assms
  by (cases x; auto)

lemma map_of_Cons_SomeE:
  assumes "map_of ((x, y) # xs) x' = Some y'"
  obtains "x' = x" and "y' = y" | "map_of xs x' = Some y'"
  using assms
  by (cases "x' = x") auto

end


\<^marker>\<open>creator "Alexander Krauss"\<close>
\<^marker>\<open>creator "Kevin Kappelmann"\<close>
\<^marker>\<open>creator "Larry Paulson"\<close>
section \<open>Replacement on Function-Like Predicates\<close>
theory Replacement_Predicates
  imports Comprehension
begin

text \<open>Replacement based on function-like predicates, as formulated in first-order theories.\<close>

definition replace :: \<open>set \<Rightarrow> (set \<Rightarrow> set \<Rightarrow> bool) \<Rightarrow> set\<close>
  where "replace A P = {THE y. P x y | x \<in> {x \<in> A | \<exists>!y. P x y}}"

bundle hotg_replacement_syntax
begin
syntax
  "_replace" :: \<open>[pttrn, pttrn, set, set \<Rightarrow> set \<Rightarrow> bool] => set\<close> ("{_ |/ _ \<in> _, _}")
end
bundle no_hotg_replacement_syntax
begin
no_syntax
  "_replace" :: \<open>[pttrn, pttrn, set, set \<Rightarrow> set \<Rightarrow> bool] => set\<close> ("{_ |/ _ \<in> _, _}")
end
unbundle hotg_replacement_syntax
translations
  "{y | x \<in> A, Q}" \<rightleftharpoons> "CONST replace A (\<lambda>x y. Q)"

lemma mem_replace_iff:
  "b \<in> {y | x \<in> A, P x y} \<longleftrightarrow> (\<exists>x \<in> A. P x b \<and> (\<forall>y. P x y \<longrightarrow> y = b))"
proof -
  have "b \<in> {y | x \<in> A, P x y} \<longleftrightarrow> (\<exists>x \<in> A. (\<exists>!y. P x y) \<and> b = (THE y. P x y))"
    using replace_def by auto
  also have "... \<longleftrightarrow> (\<exists>x \<in> A. P x b \<and> (\<forall>y. P x y \<longrightarrow> y = b))"
  proof (rule bex_cong[OF refl])
    fix x assume "x \<in> A"
    show
      "(\<exists>!y. P x y) \<and> b = (THE y. P x y) \<longleftrightarrow> P x b \<and> (\<forall>y. P x y \<longrightarrow> y = b)"
      (is "?lhs \<longleftrightarrow> ?rhs")
    proof
      assume "?lhs"
      then have ex1: "\<exists>!y. P x y" and b_eq: "b = (THE y. P x y)" by auto
      show ?rhs
      proof
        from ex1 show "P x b" unfolding b_eq by (rule theI')
        with ex1 show "\<forall>y. P x y \<longrightarrow> y = b" unfolding Ex1_def by blast
      qed
    next
      assume ?rhs
      then have P: "P x b" and uniq: "\<And>y. P x y \<Longrightarrow> y = b" by auto
      show ?lhs
      proof
        from P uniq show "\<exists>!y. P x y" by (rule ex1I)
        then show "b = (THE y. P x y)" using P by (rule the1_equality[symmetric])
      qed
    qed
  qed
  finally show ?thesis .
qed

(*Introduction; there must be a unique y such that P x y, namely y = b.*)
lemma replaceI [intro!]:
  "\<lbrakk>P x b;  x \<in> A;  \<And>y. P x y \<Longrightarrow> y = b\<rbrakk> \<Longrightarrow> b \<in> {y | x \<in> A, P x y}"
  by (rule mem_replace_iff[THEN iffD2]) blast

(*Elimination; may assume there is a unique y such that P x y, namely y = b.*)
lemma replaceE:
  assumes "b \<in> {y | x \<in> A, P x y}"
  obtains x where "x \<in> A" and "P x b" and "\<And>y. P x y \<Longrightarrow> y = b"
  using assms by (rule mem_replace_iff[THEN iffD1, THEN bexE]) blast

(*As above but without the (generally useless) third assumption*)
lemma replaceE' [elim!]:
  assumes "b \<in> {y | x \<in> A, P x y}"
  obtains x where "x \<in> A" "P x b"
  using assms by (elim replaceE) blast

lemma replace_cong [cong]:
  "\<lbrakk>A = B; \<And>x y. x \<in> B \<Longrightarrow> P x y \<longleftrightarrow> Q x y\<rbrakk> \<Longrightarrow> {y | x \<in> A, P x y} = {y | x \<in> B, Q x y}"
  by (rule eqI') (simp add: mem_replace_iff)

lemma mono_replace_set: "mono (\<lambda>A. {y | x \<in> A, P x y})"
  by (intro monoI) (auto elim!: replaceE)

end


(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics written for Isabelle/Isar.

    Copyright (C) 2022  Daniel de la Concepcion

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT,
INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES LOSS OF USE, DATA, OR PROFITS OR
BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

section \<open>Rings - Zariski Topology\<close>

text\<open>This file deals with the definition of the topology on the set of prime ideals\<close>

text\<open>It defines the topology, computes the closed sets and the closure and interior operators\<close>

theory Ring_Zariski_ZF imports Ring_ZF_2 Topology_ZF

begin

text\<open>The set where the topology is defined is in the spectrum
of a ring; i.e. the set of all prime ideals.\<close>

definition (in ring0) Spec where
"Spec \<equiv> {I\<in>\<I>. I\<triangleleft>\<^sub>pR}"

text\<open>The basic set that defines the topoogy is given
by the D operator\<close>

definition (in ring0) openBasic ("D") where
"S\<subseteq>R \<Longrightarrow> D(S) \<equiv> {I\<in>Spec. \<not>(S\<subseteq>I)}"

text\<open>The D operator preserves subsets\<close>

lemma (in ring0) D_operator_preserve_subset:
  assumes "S \<subseteq> T" "T\<subseteq>R"
  shows "D(S) \<subseteq> D(T)"
proof
  from assms have S:"S\<subseteq>R" by auto
  fix x assume "x\<in>D(S)"
  then have x:"x\<in>Spec" "\<not>(S\<subseteq>x)" using openBasic_def S by auto
  with assms(1) have "x\<in>Spec" "\<not>(T\<subseteq>x)" by auto
  then show "x:D(T)" using openBasic_def assms(2) by auto
qed

text\<open>The D operator values can be obtained by considering only ideals.
This is useful as we have operations on ideals that we do not have on subsets.\<close>

lemma (in ring0) D_operator_only_ideals:
  assumes "T\<subseteq>R"
  shows "D(T) = D(\<langle>T\<rangle>\<^sub>I)"
proof
  have T:"T\<subseteq>\<langle>T\<rangle>\<^sub>I" "\<langle>T\<rangle>\<^sub>I \<subseteq>R" using generated_ideal_contains_set assms
    generated_ideal_is_ideal[OF assms] ideal_dest_subset by auto
  with D_operator_preserve_subset show "D(T) \<subseteq> D(\<langle>T\<rangle>\<^sub>I)"
    by auto
  {
    fix t assume "t\<in>D(\<langle>T\<rangle>\<^sub>I)"
    with T(2) have t:"t\<in>Spec" "\<not>(\<langle>T\<rangle>\<^sub>I \<subseteq>t)" using openBasic_def by auto
    {
      assume as:"T \<subseteq> t"
      from t(1) have "t\<triangleleft>R" unfolding Spec_def primeIdeal_def by auto
      with as have "\<langle>T\<rangle>\<^sub>I \<subseteq>t" using generated_ideal_small by auto
      with t(2) have False by auto
    }
    then have "\<not>(T \<subseteq> t)" by auto
    with t(1) have "t\<in>D(T)" using openBasic_def assms by auto
  }
  then show "D(\<langle>T\<rangle>\<^sub>I) \<subseteq> D(T)" by auto
qed

text\<open>The intersection of to D-sets is the D-set on the
product of ideals\<close>

lemma (in ring0) intersection_open_basic:
  assumes "I\<triangleleft>R" "J\<triangleleft>R"
  shows "D(I)\<inter>D(J) = D(I\<cdot>\<^sub>IJ)"
proof
  have S:"I\<cdot>\<^sub>IJ \<subseteq> R" using product_in_intersection(2) ideal_dest_subset assms by auto
  {
    fix K assume K:"K\<in>D(I)\<inter>D(J)"
    then have "K\<triangleleft>\<^sub>pR" "\<not>(I\<subseteq>K)" "\<not>(J\<subseteq>K)"
      using assms ideal_dest_subset openBasic_def
      unfolding Spec_def by auto
    then have "\<not>(I\<subseteq>K)" "\<not>(J\<subseteq>K)" "\<forall>I\<in>\<I>. \<forall>J\<in>\<I>. I\<cdot>\<^sub>IJ\<subseteq>K \<longrightarrow> I \<subseteq> K \<or> J \<subseteq> K"
      unfolding primeIdeal_def by auto
    then have "\<not>(I\<cdot>\<^sub>IJ\<subseteq>K)" using assms
      using ideal_dest_subset[of I] ideal_dest_subset[of J] by auto
    moreover note K
    ultimately have "K\<in>D(I\<cdot>\<^sub>IJ)" using openBasic_def[of "I"]
      ideal_dest_subset[OF assms(1)]
      unfolding Spec_def openBasic_def[OF S] by auto
  }
  then show "D(I)\<inter>D(J) \<subseteq> D(I\<cdot>\<^sub>IJ)" by auto
  {
    fix K assume Kass:"K\<in>D(I\<cdot>\<^sub>IJ)"
    then have K:"K\<triangleleft>\<^sub>pR" "\<not>(I\<cdot>\<^sub>IJ\<subseteq>K)" using openBasic_def[OF S] unfolding Spec_def by auto
    {
      assume "I \<subseteq> K \<or> J \<subseteq>K"
      then have "I\<inter>J \<subseteq> K" by auto
      then have "I\<cdot>\<^sub>IJ\<subseteq>K" using product_in_intersection assms by auto
      with K(2) have False by auto
    }
    then have "\<not>(I\<subseteq>K)" "\<not>(J\<subseteq>K)" by auto
    with Kass have "K\<in>D(I)\<inter>D(J)" using assms ideal_dest_subset
      openBasic_def[of I] openBasic_def[of J]
      unfolding openBasic_def[OF S] Spec_def by auto
  }
  then show "D(I \<cdot>\<^sub>I J) \<subseteq> D(I) \<inter> D(J)" by auto
qed

text\<open>The union of D-sets is the D-set of the sum of the ideals\<close>

lemma (in ring0) union_open_basic:
  assumes "\<J> \<subseteq> \<I>"
  shows "\<Union>{D(I). I\<in>\<J>} = D(\<oplus>\<^sub>I\<J>)"
proof
  have S:"(\<oplus>\<^sub>I\<J>) \<subseteq> R" using generated_ideal_is_ideal[of "\<Union>\<J>"] assms
      unfolding sumArbitraryIdeals_def[OF assms]
      using ideal_dest_subset by auto
  {
    fix t assume "t\<in>\<Union>{D(I). I\<in>\<J>}"
    then obtain K where K:"K\<in>\<J>" "t\<in>D(K)" by auto
    then have t:"t\<triangleleft>\<^sub>pR" "\<not>(K\<subseteq>t)" using assms openBasic_def unfolding Spec_def by auto
    {
      assume "(\<oplus>\<^sub>I\<J>) \<subseteq> t"
      then have "\<Union>\<J> \<subseteq> t" using generated_ideal_contains_set[of "\<Union>\<J>"]
        assms unfolding sumArbitraryIdeals_def[OF assms] by auto
      with K(1) have "K \<subseteq> t" by auto
      with t(2) have False by auto
    }
    then have "\<not>((\<oplus>\<^sub>I\<J>) \<subseteq> t)" by auto moreover
    note K S ultimately have "t\<in>D(\<oplus>\<^sub>I\<J>)" using openBasic_def[of K] openBasic_def[of "\<oplus>\<^sub>I\<J>"]
      assms by auto
  }
  then show "\<Union>{D(I). I\<in>\<J>} \<subseteq> D(\<oplus>\<^sub>I\<J>)" by auto
  {
    fix t assume as:"t\<in>D(\<oplus>\<^sub>I\<J>)"
    then have t:"t\<in>Spec" "\<not>((\<oplus>\<^sub>I\<J>)\<subseteq>t)" unfolding openBasic_def[OF S]
      by auto
    {
      assume "\<Union>\<J> \<subseteq> t"
      with t(1) have "\<langle>\<Union>\<J>\<rangle>\<^sub>I \<subseteq> t" using generated_ideal_small
        unfolding Spec_def primeIdeal_def
        by auto
      with t(2) have False unfolding sumArbitraryIdeals_def[OF assms]
        by auto
    }
    then obtain J where J:"\<not>(J \<subseteq> t)" "J\<in>\<J>" by auto
    note J(1) moreover have "J\<subseteq>R" using `J\<in>\<J>` assms by auto
    moreover note t(1) ultimately have "t\<in>D(J)" using openBasic_def[of J]
      by auto
    then have "t:\<Union>{D(I). I\<in>\<J>}" using J(2) by auto
  }
  then show "D(\<oplus>\<^sub>I\<J>) \<subseteq> \<Union>{D(I). I\<in>\<J>}" by auto
qed

text\<open>From the previous results on intesertion and union,
we conclude that the D-sets we computed form a topology\<close>

corollary (in ring0) zariski_top:
  shows "{D(J). J\<in>\<I>}{is a topology}" unfolding IsATopology_def
proof(safe)
  fix M assume "M \<subseteq> {D(J). J\<in>\<I>}"
  then have "M = {D(J). J\<in>{K\<in>\<I>. D(K)\<in>M}}" by auto
  then have "\<Union>M = \<Union>{D(J). J\<in>{K\<in>\<I>. D(K)\<in>M}}" by auto
  then have "\<Union>M = D(\<oplus>\<^sub>I{K\<in>\<I>. D(K)\<in>M})" using union_open_basic[of "{K \<in> \<I> . D(K) \<in> M}"] by auto
  moreover have "(\<oplus>\<^sub>I{K\<in>\<I>. D(K)\<in>M})\<triangleleft>R" using
    generated_ideal_is_ideal[of "\<Union>{K\<in>\<I>. D(K)\<in>M}"]
    sumArbitraryIdeals_def [of "{K\<in>\<I>. D(K)\<in>M}"]
    by force
  then have "(\<oplus>\<^sub>I{K\<in>\<I>. D(K)\<in>M})\<in>\<I>" using ideal_dest_subset
    by auto
  ultimately show "\<Union>M:{D(J). J\<in>\<I>}" by auto
next
  fix x xa assume as:"x\<triangleleft>R" "xa\<triangleleft>R"
  then have "D(x) \<inter> D(xa) = D(x\<cdot>\<^sub>Ixa)" using intersection_open_basic
    by auto
  moreover have "(x\<cdot>\<^sub>Ixa) \<triangleleft>R" using product_in_intersection(2)
    as by auto
  then have "(x\<cdot>\<^sub>Ixa):\<I>" using ideal_dest_subset by auto
  ultimately show "D(x) \<inter> D(xa)\<in>{D(J). J\<in>\<I>}" by auto
qed

text\<open>We include all the results of topology0
  into ring0 under the namespace "zariski"\<close>

definition(in ring0) ZarInt ("int") where
  "int(U) \<equiv> Interior(U,{D(J). J\<in>\<I>})"

definition (in ring0) ZarCl ("cl") where
  "cl(U) \<equiv> Closure(U,{D(J). J\<in>\<I>})"

definition (in ring0) ZarBound ("\<partial>_") where
  "\<partial>U \<equiv> Boundary(U,{D(J). J\<in>\<I>})"

sublocale ring0 < zariski:topology0 "{D(J). J\<in>\<I>}"
  ZarInt ZarCl ZarBound unfolding topology0_def
  ZarBound_def ZarInt_def ZarCl_def
  using zariski_top by auto

text\<open>The interior of a proper subset is given by the D-set
of the intersection of all the prime ideals not in that subset\<close>
lemma (in ring0) interior_zariski:
  assumes "U \<subseteq> Spec" "U\<noteq>Spec"
  shows "int(U) = D(\<Inter>(Spec-U))"
proof
  {
    fix t assume t:"t\<in>\<Inter>(Spec-U)"
    then have "\<forall>V\<in>Spec-U. t:V" by auto
    moreover from t have "(Spec-U) \<noteq>0" by auto
    ultimately obtain V where "V\<in>Spec-U" "t\<in>V" by auto
    then have "t\<in>\<Union>Spec" by auto
    then have "t\<in>R" unfolding Spec_def by auto
  }
  then have S:"\<Inter>(Spec-U) \<subseteq> R" by auto
  {
    fix t assume "t\<in>D(\<Inter>(Spec-U))"
    then have t:"t:Spec" "\<not>(\<Inter>(Spec-U) \<subseteq> t)" using openBasic_def[OF S]
      by auto
    {
      assume "t\<notin>U"
      with t(1) have "t\<in>Spec-U" by auto
      then have "\<Inter>(Spec-U) \<subseteq> t" by auto
      then have False using t(2) by auto
    }
    then have "t\<in>U" by auto
  }
  then have "D(\<Inter>(Spec-U)) \<subseteq> U" by auto moreover
  {
    assume "Spec-U = 0"
    with assms(1) have "U=Spec" by auto
    with assms(2) have False by auto
  }
  then have P:"Spec-U \<subseteq> \<I>" "Spec-U \<noteq>0" unfolding Spec_def by auto
  then have "(\<Inter>(Spec-U))\<triangleleft>R" using intersection_ideals by auto
  then have "(\<Inter>(Spec-U))\<in>\<I>" using ideal_dest_subset by auto
  then have "D(\<Inter>(Spec-U)) \<in>{D(J). J\<in>\<I>}" by auto
  ultimately
  show "D(\<Inter>(Spec-U)) \<subseteq>int(U)" using zariski.Top_2_L5 by auto
  {
    fix V assume V:"V\<in>{D(J). J\<in>\<I>}" "V \<subseteq> U"
    from V(1) obtain J where J:"J:\<I>" "V=D(J)" by auto
    from V(2) have SS:"Spec-U \<subseteq> Spec-V" by auto
    {
      fix K assume K:"K\<in>Spec-U"
      {
        assume "\<not>(J\<subseteq>K)"
        with K have "K\<in>D(J)" using J(1) using openBasic_def
          by auto
        with SS K J(2) have False by auto
      }
      then have "J\<subseteq>K" by auto
    }
    then have "J\<subseteq> \<Inter>(Spec-U)" using P(2) by auto
    then have "D(J) \<subseteq> D(\<Inter>(Spec-U))" using D_operator_preserve_subset
      S by auto
    with J(2) have "V \<subseteq>D(\<Inter>(Spec-U))" by auto
  }
  then show "int(U) \<subseteq> D(\<Inter>(Spec-U))" using
    zariski.Top_2_L1 zariski.Top_2_L2 by auto
qed

text\<open>The whole space is the D-set of the ring as an ideal of itself\<close>

lemma (in ring0) openBasic_total:
  shows "D(R) = Spec"
proof
  show "D(R) \<subseteq> Spec" using openBasic_def by auto
  {
    fix t assume t:"t\<in>Spec"
    {
      assume "R \<subseteq> t"
      then have False using t unfolding Spec_def primeIdeal_def
        using ideal_dest_subset[of t] by auto
    }
    with t have "t\<in>D(R)" using openBasic_def by auto
  }
  then show "Spec \<subseteq> D(R)" by auto
qed

corollary (in ring0) total_spec:
  shows "\<Union>{D(J). J\<in>\<I>} = Spec"
proof
  show "\<Union>{D(J). J\<in>\<I>} \<subseteq> Spec" using openBasic_def by auto
  have "D(R)\<in>{D(J). J\<in>\<I>}" using R_ideal by auto
  then have "D(R) \<subseteq> \<Union>{D(J). J\<in>\<I>}" by auto
  then show "Spec \<subseteq> \<Union>{D(J). J\<in>\<I>}" using openBasic_total by auto
qed

text\<open>The empty set is the D-set of the zero ideal\<close>

lemma (in ring0) openBasic_empty:
  shows "D({\<zero>}) = 0"
proof-
  {
    fix t assume t:"t\<in>D({\<zero>})"
    then have "t\<triangleleft>\<^sub>pR" "\<not>({\<zero>} \<subseteq> t)" using openBasic_def
      Ring_ZF_1_L2(1) unfolding Spec_def by auto
    then have False using ideal_dest_zero unfolding primeIdeal_def by auto
  }
  then show "D({\<zero>}) =0" by auto
qed

text\<open>A closed set is a set of primes containing a given
ideal\<close>

lemma (in ring0) closeBasic:
  assumes "U{is closed in}{D(J). J\<in>\<I>}"
  obtains J where "J\<in>\<I>" and "U={K\<in>Spec. J\<subseteq>K}"
proof-
  assume rule:"\<And>J. J \<in> \<I> \<Longrightarrow> U = {K \<in> Spec . J \<subseteq> K} \<Longrightarrow> thesis"
  from assms have U:"U\<subseteq>Spec" "Spec-U \<in> {D(J). J\<in>\<I>}" unfolding IsClosed_def
    using total_spec by auto
  then obtain J where J:"J\<in>\<I>" "Spec-U = D(J)" by auto
  moreover from U(1) have "Spec-(Spec-U) = U" by auto
  ultimately have "U = Spec-{K\<in>Spec. \<not>(J\<subseteq>K)}" using openBasic_def
    by auto
  then have "U = {K\<in>Spec. J\<subseteq>K}" by auto
  with J show ?thesis using rule by auto
qed

text\<open>We define the closed sets as V-sets\<close>

definition (in ring0) closeBasic ("V") where
"S \<subseteq> R \<Longrightarrow> V(S) = {K\<in>Spec. S\<subseteq>K}"

text\<open>V-sets and D-sets are complementary\<close>

lemma (in ring0) V_is_closed:
  assumes "J\<in>\<I>"
  shows "Spec-V(J) = D(J)" and "V(J){is closed in}{D(J). J\<in>\<I>}"
  unfolding IsClosed_def
proof(safe)
  from assms have "V(J) \<subseteq> Spec" using closeBasic_def by auto
  then show "\<And>x. x \<in> V(J) \<Longrightarrow> x \<in> \<Union>RepFun(\<I>, D)" using total_spec by auto
  show "Spec-V(J) = D(J)" using assms
    closeBasic_def openBasic_def by auto
  with assms show "\<Union>RepFun(\<I>, D) - V(J) \<in> RepFun(\<I>, D)"
    using total_spec by auto
qed

text\<open>As with D-sets, by De Morgan's Laws we get the same result
for unions and intersections on V-sets\<close>

lemma (in ring0) V_union:
  assumes "J\<in>\<I>" "K\<in>\<I>"
  shows "V(J)\<union>V(K) = V(J\<cdot>\<^sub>IK)"
proof-
  {
    fix t assume "t\<in>V(J)"
    then have "t\<in>Spec" "J\<subseteq>t" using closeBasic_def
      assms(1) by auto
    moreover have "J\<cdot>\<^sub>IK \<subseteq> J" using product_in_intersection(1)[of J K]
      assms by auto
    ultimately have "t\<in>Spec" "J\<cdot>\<^sub>IK \<subseteq>t" by auto
    then have "t: V(J\<cdot>\<^sub>IK)" using closeBasic_def
      product_in_intersection(2)[of J K] assms ideal_dest_subset
      by auto
  }
  moreover
  {
    fix t assume "t\<in>V(K)"
    then have "t\<in>Spec" "K\<subseteq>t" using closeBasic_def
      assms(2) by auto
    moreover have "J\<cdot>\<^sub>IK \<subseteq> K" using product_in_intersection(1)[of J K]
      assms by auto
    ultimately have "t\<in>Spec" "J\<cdot>\<^sub>IK \<subseteq>t" by auto
    then have "t: V(J\<cdot>\<^sub>IK)" using closeBasic_def
      product_in_intersection(2)[of J K] assms ideal_dest_subset
      by auto
  }
  moreover
  {
    fix t assume "t\<in> V(J\<cdot>\<^sub>IK)"
    then have t:"t\<in>Spec" "J\<cdot>\<^sub>IK\<subseteq>t" using closeBasic_def
      assms product_in_intersection(2)[of J K]
      ideal_dest_subset by auto
    from this(1) have "\<forall>Ia\<in>\<I>. \<forall>J\<in>\<I>. Ia \<cdot>\<^sub>I J \<subseteq> t \<longrightarrow> Ia \<subseteq> t \<or> J \<subseteq> t"
      unfolding Spec_def primeIdeal_def by blast
    with assms have "J\<cdot>\<^sub>IK\<subseteq>t \<longrightarrow> J\<subseteq>t \<or> K\<subseteq>t" by auto
    with t have "t\<in>Spec"  "J \<subseteq> t \<or> K \<subseteq> t" by auto
    then have "t\<in>V(J)\<union>V(K)" using closeBasic_def
      assms by auto
  }
  ultimately show ?thesis by auto
qed

lemma (in ring0) V_intersect:
  assumes "\<J> \<subseteq> \<I>" "\<J> \<noteq>0"
  shows "\<Inter>{V(I). I\<in>\<J>} = V(\<oplus>\<^sub>I\<J>)"
proof-
  have "Spec - (\<Inter>{V(I). I\<in>\<J>}) = \<Union>{D(I). I\<in>\<J>}"
  proof
    {
      fix t assume "t:Spec - (\<Inter>{V(I). I\<in>\<J>})"
      then have t:"t:Spec" "t\<notin>\<Inter>{V(I). I\<in>\<J>}" by auto
      from t(2) obtain K where "(t\<notin>V(K) \<and> K\<in>\<J>) \<or> \<J>=0" by auto
      with assms(2) have "t\<notin>V(K)" "K\<in>\<J>" by auto
      with t(1) have "t\<in>Spec-V(K)" "K:\<J>" by auto moreover
      from `K:\<J>` have "Spec-V(K) = D(K)" using assms(1) V_is_closed(1) by auto
      ultimately have "t:D(K)" "K:\<J>" by auto
      then have "t\<in>\<Union>{D(I). I\<in>\<J>}" by auto
    }
    then show "Spec - (\<Inter>{V(I). I\<in>\<J>}) \<subseteq> \<Union>{D(I). I\<in>\<J>}" by auto
    {
      fix t assume "t\<in>\<Union>{D(I). I\<in>\<J>}"
      then obtain K where K:"K:\<J>" "t:D(K)" using assms(2)
        by auto
      from `K:\<J>` have "Spec-V(K) = D(K)" using assms(1) V_is_closed(1) by auto
      with K(2) have "t:Spec-V(K)" by auto
      with K(1) have "t\<in>Spec-\<Inter>{V(I). I:\<J>}" by auto
    }
    then show "\<Union>{D(I). I\<in>\<J>} \<subseteq> Spec - (\<Inter>{V(I). I\<in>\<J>})" by auto
  qed
  then have "Spec - (\<Inter>{V(I). I\<in>\<J>}) = D(\<oplus>\<^sub>I\<J>)" using union_open_basic
    assms by auto
  then have "Spec-(Spec - (\<Inter>{V(I). I\<in>\<J>})) = Spec- D(\<oplus>\<^sub>I\<J>)" by auto
  moreover
  have JI:"(\<oplus>\<^sub>I\<J>) \<in> \<I>" using generated_ideal_is_ideal[of "\<Union>\<J>"] assms
    unfolding sumArbitraryIdeals_def[OF assms(1)]
    using ideal_dest_subset by auto
  then have "Spec- V(\<oplus>\<^sub>I\<J>) = D(\<oplus>\<^sub>I\<J>)" using V_is_closed(1)[of "\<oplus>\<^sub>I\<J>"]
    by auto
  then have "Spec-(Spec-V(\<oplus>\<^sub>I\<J>) ) = Spec-D(\<oplus>\<^sub>I\<J>)" by auto
  ultimately have R:"Spec-(Spec - (\<Inter>{V(I). I\<in>\<J>})) = Spec-(Spec-V(\<oplus>\<^sub>I\<J>) )"
    by auto
  {
    fix t assume t:"t\<in>\<Inter>{V(I). I\<in>\<J>}"
    with assms(2) obtain I where "I:\<J>" "t:V(I)" by auto
    then have "t\<in>Spec" using closeBasic_def assms(1)
      by auto
    with t have "t\<in>Spec-(Spec - (\<Inter>{V(I). I\<in>\<J>}))" by auto
    with R have "t\<in>Spec-(Spec-V(\<oplus>\<^sub>I\<J>) )" by auto
    then have "t\<in>V(\<oplus>\<^sub>I\<J>)" by auto
  } moreover
  {
    fix t assume t:"t\<in>V(\<oplus>\<^sub>I\<J>)"
    with JI have "t:Spec" using closeBasic_def by auto
    with t have "t\<in>Spec-(Spec-V(\<oplus>\<^sub>I\<J>) )" by auto
    then have "t\<in>Spec-(Spec - (\<Inter>{V(I). I\<in>\<J>}))" using R by auto
    then have "t\<in>\<Inter>{V(I). I\<in>\<J>}" by auto
  }
  ultimately show ?thesis by force
qed

text\<open>The closure of a set is the V-set of the intersection
of all its points.\<close>

lemma (in ring0) closure_zariski:
  assumes "U \<subseteq> Spec" "U\<noteq>0"
  shows "cl(U) = V(\<Inter>U)"
proof
  have "U \<subseteq> \<I>" using assms(1) unfolding Spec_def by auto
  then have ideal:"(\<Inter>U)\<triangleleft>R" using intersection_ideals[of U] assms(2) by auto
  {
    fix t assume t:"t\<in>V(\<Inter>U)"
    {
      fix q assume q:"q\<in>\<Inter>U"
      with q obtain M where "M:U" "q:M" using assms(2) by blast
      with assms have "q\<in>\<Union>Spec" by auto
      then have "q:R" unfolding Spec_def by auto
    }
    then have sub:"\<Inter>U \<subseteq> R" by auto
    with t have tt:"t\<in>Spec" "\<Inter>U \<subseteq> t" using closeBasic_def by auto
    {
      fix VV assume VV:"VV\<in>{D(J). J\<in>\<I>}" "t\<in>VV"
      then obtain J where J:"VV= D(J)" "J\<in>\<I>" by auto
      from VV(2) J have jt:"\<not>(J \<subseteq> t)" using openBasic_def by auto
      {
        assume "U\<inter>D(J) = 0"
        then have "\<forall>x\<in>U. x\<notin>D(J)" by auto
        with J(2) have "\<forall>x\<in>U. J\<subseteq>x" using openBasic_def[of J]
          assms(1) by auto
        then have "J\<subseteq> \<Inter>U \<or> U=0" by auto
        with tt(2) jt have False using assms(2) by auto
      }
      then have "U\<inter>VV \<noteq> 0" using J(1) by auto
    }
    then have R:"\<forall>VV\<in>{D(J). J\<in>\<I>}. t\<in>VV \<longrightarrow> VV\<inter>U \<noteq> 0" by auto
    from tt(1) assms(1) have RR:"t\<in>\<Union>{D(J). J\<in>\<I>}" "U \<subseteq> \<Union>{D(J). J\<in>\<I>}"
      using total_spec by auto
    have "t\<in>cl(U)" using zariski.inter_neigh_cl[OF RR(2,1) R].
  }
  then show "V(\<Inter>U) \<subseteq> cl(U)"
    apply (rule subsetI) by auto
  {
    fix p assume p:"p\<in>U"
    then have "\<Inter>U \<subseteq>p" by auto
    moreover
    from p assms(1) have "p\<in>Spec" "\<Inter>U\<subseteq>\<Union>Spec" by auto
    then have "p\<in>Spec" "\<Inter>U\<subseteq>R" unfolding Spec_def by auto
    ultimately have "p\<in>V(\<Inter>U)" using closeBasic_def[of "\<Inter>U"]
      by auto
  }
  then have A:"U\<subseteq>V(\<Inter>U)" by auto
  have B:"V(\<Inter>U){is closed in}{D(J). J\<in>\<I>}"
    using V_is_closed(2) ideal ideal_dest_subset by auto
  show "cl(U) \<subseteq> V(\<Inter>U)"
    apply (rule zariski.Top_3_L13[of "V(\<Inter>U)" U])
    using A B by auto
qed

end


section \<open>Fundamental Definitions\<close>

subsection \<open>Reductions\<close>

theory Reductions
  imports Main
begin

definition is_reduction :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> bool" where
  "is_reduction f A B \<equiv> \<forall>a. a \<in> A \<longleftrightarrow> f a \<in> B "

lemma is_reduction_trans:
  assumes "is_reduction f A B" "is_reduction g B C"
  shows "is_reduction (g o f) A C"
  using assms unfolding is_reduction_def by auto

end


theory deMorgan2
  imports Main

begin

text\<open> Apply style \<close>
theorem de_morgan_2 : "((\<not> p \<and> \<not> q)  \<longrightarrow> (\<not> (p \<or> q)))"
  apply (rule impI)
  apply (rule notI)
  apply (erule disjE)
  apply (erule conjE)
  apply (erule notE)
  apply assumption
  apply (erule conjE)
  apply (erule notE)
  apply (erule notE)
  apply assumption
  done
end


(* Title:     MiniML/Maybe.thy
   Author:    Wolfgang Naraschewski and Tobias Nipkow
   Copyright  1996 TU Muenchen
*)

section "Universal error monad"

theory Maybe
imports Main
begin

definition
  option_bind :: "['a option, 'a => 'b option] => 'b option" where
  "option_bind m f = (case m of None => None | Some r => f r)"

syntax "_option_bind" :: "[pttrns,'a option,'b] => 'c" ("(_ := _;//_)" 0)
translations "P := E; F" == "CONST option_bind E (\<lambda>P. F)"

\<comment> \<open>constructor laws for @{text option_bind}\<close>
lemma option_bind_Some: "option_bind (Some s) f = (f s)"
  by (simp add: option_bind_def)

lemma option_bind_None: "option_bind None f = None"
  by (simp add: option_bind_def)

declare option_bind_Some [simp] option_bind_None [simp]

\<comment> \<open>expansion of @{text option_bind}\<close>
lemma split_option_bind: "P(option_bind res f) =
          ((res = None \<longrightarrow> P None) \<and> (\<forall>s. res = Some s \<longrightarrow> P(f s)))"
  unfolding option_bind_def
  by (rule option.split)

lemma split_option_bind_asm: "P(option_bind res f) =
          (~ ((res = None \<and> \<not> P None) \<or> (\<exists>s. res = Some s \<and> \<not> P(f s))))"
  unfolding option_bind_def
  by (rule option.split_asm)

lemma option_bind_eq_None [simp]:
    "((option_bind m f) = None) = ((m=None) | (\<exists>p. m = Some p \<and> f p = None))"
  by (simp split: split_option_bind)

lemma rotate_Some: "(y = Some x) = (Some x = y)"
  by (simp add: eq_sym_conv)

end