chapter \<open>IMP++\<close>
theory IMPlusPlus
imports
  Main
  "~~/src/HOL/Library/Monad_Syntax"
  "~~/src/HOL/Eisbach/Eisbach"
  "~~/src/HOL/Library/Rewrite"
begin

text \<open>
  Extension of IMP by generalized arrays and the common arithmetic and Boolean operations.

  In this language, each variable stores a map from integers to integers.

  Initially, all integers are mapped to zero.

  In an expression, and on the LHS of an assignment, only indexed variables are allowed.
  That is, all expressions compute with single integers.
  \<open> x[3] ::= y[0] + 5 \<close>

  The Clear operation resets the mapping of a variable to all zeroes.
  \<open>CLR x\<close>

  If the index is omitted, variables are indexed at zero.
  This allows to use the variables as if they held single values.
  \<open>x ::= y + 5\<close> is the same as \<open>x[0] ::= y[0] + 5\<close>

  Summarized:
    \<^item> Every variable is an array, but, by default, we only use index zero.
    \<^item> Arrays can be indexed by arbitrary integers (including negative ones),
      and dynamically grow as needed.
\<close>

section \<open>Miscellaneous\<close>

ML \<open>
  local
    val ctxt = @{context} |> Splitter.del_split @{thm if_split}
    val ctxt = ctxt
      delsimps @{thms fun_upd_apply}
      addsimps @{thms fun_upd_same fun_upd_other}
  in
    val IMP_basic_ss = Simplifier.simpset_of ctxt
  end
\<close>

setup \<open>
  let
    open Simplifier

    (* FIXME: Copied from Simplifier, as these things are not exposed to the user *)

    val simpN = "simp";
    val congN = "cong";
    val onlyN = "only";
    val no_asmN = "no_asm";
    val no_asm_useN = "no_asm_use";
    val no_asm_simpN = "no_asm_simp";
    val asm_lrN = "asm_lr";

    val simp_options =
     (Args.parens (Args.$$$ no_asmN) >> K simp_tac ||
      Args.parens (Args.$$$ no_asm_simpN) >> K asm_simp_tac ||
      Args.parens (Args.$$$ no_asm_useN) >> K full_simp_tac ||
      Args.parens (Args.$$$ asm_lrN) >> K asm_lr_simp_tac ||
      Scan.succeed asm_full_simp_tac);

    fun transform_context f (ctxt,ts) = ((),(Context.map_proof f ctxt,ts))

    fun simp_method more_mods meth =
      Scan.lift simp_options --| transform_context (put_simpset IMP_basic_ss) --|
        Method.sections (more_mods @ simp_modifiers') >>
        (fn tac => fn ctxt => METHOD (fn facts => meth ctxt tac facts));

    (** setup **)

    fun method_setup more_mods =
      Method.setup @{binding imp_basic_simp}
        (simp_method more_mods (fn ctxt => fn tac => fn facts =>
          HEADGOAL (Method.insert_tac ctxt facts THEN'
            (CHANGED_PROP oo tac) ctxt)))
        "simplification with basic simpset for IMP"
  in
    method_setup []
  end
\<close>

(* Required to "instantiate" existential without introducing new variable,
  which would not unify with already introduced schematic *)
lemma ex_eq_some: "(\<exists>x. P x) \<longleftrightarrow> P (SOME x. P x)"
  by (meson someI)

section \<open>Syntax\<close>

subsection \<open>Variables and Constants\<close>
type_synonym vname = string

type_synonym val = int

subsection \<open>Arithmetic Expressions\<close>
datatype aexp =
    N int            -- \<open>Constant\<close>
  | V vname aexp     -- \<open>Array at index \<open>x[i]\<close>\<close>
  | Binop "int \<Rightarrow> int \<Rightarrow> int" aexp aexp -- \<open>Binary operation\<close>

abbreviation "V0 x \<equiv> V (x) (N 0)" -- \<open>Abbreviation for \<open>x[0]\<close>\<close>

abbreviation "Plus \<equiv> Binop (op+)"
abbreviation "Minus \<equiv> Binop (op-)"
abbreviation "Times \<equiv> Binop (op*)"

text \<open>Warning, the following two also give defined results on division by zero!\<close>
value "a div (0::int)" value "a mod (0::int)"
abbreviation "Div \<equiv> Binop (op div)"
abbreviation "Mod \<equiv> Binop (op mod)"

subsection \<open>Boolean Expressions\<close>
datatype bexp =
    Bc bool    -- \<open>True or False\<close>
  | Not bexp   -- \<open>Negation\<close>
  | BBop "bool\<Rightarrow>bool\<Rightarrow>bool" bexp bexp   -- \<open>Binary boolean operation\<close>
  | Cmpop "int \<Rightarrow> int \<Rightarrow> bool" aexp aexp -- \<open>Comparison operation\<close>

abbreviation "And \<equiv> BBop op \<and>"
abbreviation "Or \<equiv> BBop op \<or>"
abbreviation "BNEq \<equiv> BBop op \<noteq>"
abbreviation "BEq \<equiv> BBop op \<longleftrightarrow>"

abbreviation "Less \<equiv> Cmpop op <"
abbreviation "Leq \<equiv> Cmpop op \<le>"
abbreviation "Greater \<equiv> Cmpop op >"
abbreviation "Geq \<equiv> Cmpop op \<ge>"
abbreviation "Equal \<equiv> Cmpop op ="
abbreviation "NEqual \<equiv> Cmpop op \<noteq>"

subsection \<open>Commands\<close>

datatype
  com = SKIP
      | Assign vname aexp aexp  -- \<open> Assignment to index of array. \<open>x[i] = a\<close>\<close>
      | Clear  vname            -- \<open> Set all indices of array to 0\<close>
      | Seq    com  com         -- \<open> Sequential composition \<open>c\<^sub>1; c\<^sub>2\<close>\<close>
      | If     bexp com com     -- \<open> Conditional. \<open>if (b) c\<^sub>1 else c\<^sub>2\<close>\<close>
      | While  bexp com         -- \<open> While loop. \<open>while (b) c\<close>\<close>

subsection \<open>Concrete Syntax\<close>

text \<open>Like the original IMP, we only expose a minimal syntax for commands by default\<close>

notation
  Assign  ("(_[_] ::= _)" [1000,900, 41] 41) and
  Clear   ("(CLR _)" [41] 41) and
  Seq     ("(_;;/ _)"  [40, 41] 40) and
  If      ("(IF (\<open>unbreakable\<close>_) THEN(2/ _/ )ELSE(2/ _))"  [0, 0, 41] 41) and
  While   ("(WHILE (\<open>unbreakable\<close>_) DO(2/ _))"  [0, 41] 41)

text \<open>Shortcut notation for assigning to index 0. \<close>
abbreviation Assign0 ("(_ ::= _)" [1000, 41] 41)
  where "x ::= v \<equiv> (x[N 0] ::= v)"

abbreviation true where "true \<equiv> Bc True"
abbreviation false where "false \<equiv> Bc False"

text \<open>
  However, we provide a bundle with somewhat more fancy syntax.
\<close>

abbreviation (input) "IMP_Variable \<equiv> V0"
syntax "_IMPVariable" :: "id \<Rightarrow> aexp"
translations "CONST IMP_Variable" \<rightharpoonup> "_IMPVariable"

abbreviation (input) "IMP_VariableI \<equiv> V"
syntax "_IMPVariableI" :: "id \<Rightarrow> aexp \<Rightarrow> aexp"
translations "CONST IMP_VariableI" \<rightharpoonup> "_IMPVariableI"

abbreviation (input) "IMP_Assign x v \<equiv> Assign x (N 0) v"
syntax "_IMPAssign" :: "id \<Rightarrow> aexp \<Rightarrow> com"
translations "CONST IMP_Assign" \<rightharpoonup> "_IMPAssign"

abbreviation (input) "IMP_AssignI x i v \<equiv> Assign x i v"
syntax "_IMPAssignI" :: "id \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> com"
translations "CONST IMP_AssignI" \<rightharpoonup> "_IMPAssignI"

abbreviation (input) "IMP_Clear x \<equiv> Clear x"
syntax "_IMPClear" :: "id \<Rightarrow> com"
translations "CONST IMP_Clear" \<rightharpoonup> "_IMPClear"

ML \<open>
  structure IMP_Translation = struct

    val cfg_var_syntax = Attrib.setup_config_bool @{binding IMP_var_syntax} (K false)

    fun
      var_tr ctxt [(c as Const (@{syntax_const "_constrain"}, _)) $ t $ u] =
        c $ var_tr ctxt [t] $ u
    | var_tr _ [Free (str,_)] = Syntax.const (@{const_syntax V0}) $ HOLogic.mk_string str
    | var_tr _ ts = raise (TERM ("IMP_Variable",ts))

    fun
      vari_tr ctxt [(c as Const (@{syntax_const "_constrain"}, _)) $ t $ u, it] =
        c $ vari_tr ctxt [t,it] $ u
    | vari_tr _ [Free (str,_),it] = Syntax.const (@{const_syntax V}) $ HOLogic.mk_string str $ it
    | vari_tr _ ts = raise (TERM ("IMP_VariableI",ts))

    fun
      ass_tr ctxt [(c as Const (@{syntax_const "_constrain"}, _)) $ t $ u, rhst] =
        c $ ass_tr ctxt [t,rhst] $ u
    | ass_tr _ [Free (str,_),rhst] = Syntax.const (@{const_syntax Assign0}) $ HOLogic.mk_string str $ rhst
    | ass_tr _ ts = raise (TERM ("IMP_AssignI",ts))

    fun
      assi_tr ctxt [(c as Const (@{syntax_const "_constrain"}, _)) $ t $ u, it, rhst] =
        c $ assi_tr ctxt [t,it,rhst] $ u
    | assi_tr _ [Free (str,_),it,rhst] = Syntax.const (@{const_syntax Assign}) $ HOLogic.mk_string str $ it $ rhst
    | assi_tr _ ts = raise (TERM ("IMP_Assign",ts))

    fun
      clr_tr ctxt [(c as Const (@{syntax_const "_constrain"}, _)) $ t $ u] =
        c $ clr_tr ctxt [t] $ u
    | clr_tr _ [Free (str,_)] = Syntax.const (@{const_syntax Clear}) $ HOLogic.mk_string str
    | clr_tr _ ts = raise (TERM ("IMP_Clear",ts))

    fun
      dest_list_syntax (Const (@{const_syntax List.Cons},_)$x$xs)
        = x::dest_list_syntax xs
    | dest_list_syntax (Const (@{const_syntax List.Nil},_)) = []
    | dest_list_syntax _ = raise Match

    fun
      dest_char_syntax (Const (@{const_syntax String.Char}, _) $ c) =
        let
          val n = Numeral.dest_num_syntax c
          val s = chr n
        in
          s
        end
    | dest_char_syntax _ = raise Match

    fun dest_var_syntax t = let
      val s =
          dest_list_syntax t
        |> map dest_char_syntax
        |> implode
      val _ = Symbol.is_ascii_identifier s orelse raise Match
    in
      s
    end

    fun
      var_tr' _ [t:term] =
        Syntax.const @{const_syntax "IMP_Variable"} $ Syntax.const (dest_var_syntax t)
    | var_tr' _ [t:term,it] =
        Syntax.const @{const_syntax "IMP_VariableI"} $ Syntax.const (dest_var_syntax t) $ it
    | var_tr' _ _ = raise Match

    fun
      ass_tr' _ [t:term,vt] =
        Syntax.const @{const_syntax "IMP_Assign"} $ Syntax.const (dest_var_syntax t) $ vt
    | ass_tr' _ [t:term,it,vt] =
        Syntax.const @{const_syntax "IMP_AssignI"} $ Syntax.const (dest_var_syntax t) $ it $ vt
    | ass_tr' _ _ = raise Match

    fun
      clr_tr' _ [t:term] =
        Syntax.const @{const_syntax "IMP_Clear"} $ Syntax.const (dest_var_syntax t)
    | clr_tr' _ _ = raise Match

    fun if_var_syntax f ctxt =
      if Config.get ctxt cfg_var_syntax then
        f ctxt
      else
        raise Match

    val _ = Theory.setup (
      Sign.print_translation [
        (@{const_syntax "V0"}, if_var_syntax var_tr'),
        (@{const_syntax "V"}, if_var_syntax var_tr'),
        (@{const_syntax "Assign0"}, if_var_syntax ass_tr'),
        (@{const_syntax "Assign"}, if_var_syntax ass_tr'),
        (@{const_syntax "Clear"}, if_var_syntax clr_tr')
      ]
    )
    val _ = Theory.setup (
      Sign.parse_translation [
        (@{syntax_const "_IMPVariable"}, if_var_syntax var_tr),
        (@{syntax_const "_IMPVariableI"}, if_var_syntax vari_tr),
        (@{syntax_const "_IMPAssign"}, if_var_syntax ass_tr),
        (@{syntax_const "_IMPAssignI"}, if_var_syntax assi_tr),
        (@{syntax_const "_IMPClear"}, if_var_syntax clr_tr)
      ]
    )

  end
\<close>

consts
  eplus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  eminus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  etimes :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  edivide :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  emodulo :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  eequal :: "'a \<Rightarrow> 'a \<Rightarrow> 'b"
  neequal :: "'a \<Rightarrow> 'a \<Rightarrow> 'b"
  eless :: "'a \<Rightarrow> 'a \<Rightarrow> 'b"
  egreater :: "'a \<Rightarrow> 'a \<Rightarrow> 'b"

bundle IMP_Syntax begin

notation IMP_Variable ("$_" [100] 100)
notation IMP_VariableI ("_\<^bold>[_\<^bold>]" [100,0] 100)

no_notation
  Assign0 ("(_ ::= _)" [1000, 41] 41) and
  Assign  ("(_[_] ::= _)" [1000,900, 41] 41) and
  Clear   ("(CLR _)" [41] 41)

notation
  IMP_Assign ("(_ ::= _)" [1000, 41] 41) and
  IMP_AssignI  ("(_\<^bold>[_\<^bold>] ::= _)" [1000,0, 41] 41) and
  IMP_Clear   ("(CLR _)" [41] 41)

declare [[IMP_var_syntax]]

notation N ("\<acute>_" [105] 105)

no_notation
  plus  (infixl "+" 65) and
  minus (infixl "-" 65) and
  times (infixl "*" 70) and
  divide (infixl "div" 70) and
  modulo (infixl "mod" 70)

notation
  eplus   (infixl "+" 65)   and
  eminus  (infixl "-" 65)   and
  etimes  (infixl "*" 70)   and
  edivide (infixl "div" 70) and
  emodulo (infixl "mod" 70)

adhoc_overloading eplus plus Plus
adhoc_overloading eminus minus Minus
adhoc_overloading etimes times Times
adhoc_overloading edivide divide Div
adhoc_overloading emodulo modulo Mod

notation Or (infixr "||" 30)
notation And (infixr "&&" 35)
notation Not ("!_" [90] 90)

no_notation "Pure.eq" (infix "==" 2)

notation
  eequal  (infix "==" 50) and
  neequal (infix "!=" 50)

adhoc_overloading eequal BEq Equal
adhoc_overloading neequal BNEq NEqual

no_notation
  less ("(_/ < _)"  [51, 51] 50) and
  greater  (infix ">" 50) and
  less_eq  ("(_/ <= _)" [51, 51] 50) and
  greater_eq  (infix ">=" 50)

notation
  eless (infix "<"  50) and
  egreater (infix ">" 50)

adhoc_overloading eless less Less
adhoc_overloading egreater greater Greater

notation
  Leq  ("(_/ <= _)" [51, 51] 50) and
  Geq  (infix ">=" 50)

end

subsection \<open>Syntax Overview\<close>

text \<open>Activate the Syntax locally in a context\<close>
context
  includes IMP_Syntax
begin

  subsubsection \<open>Arithmetic expressions\<close>

  text \<open>Idiosyncrasies:
    \<^item> For array indexing, we use bold brackets \<open>\<^bold>[ \<^bold>]\<close>. Type \<open>\ bold [\<close> and \<open>\ bold ]\<close>
    \<^item> Prefixing a variable with \<open>$\<close> refers to index 0 of this variable.
      This way, variables, which hold maps, can conveniently be used as single values.
  \<close>

  term "$foo"       term "V0 ''foo''"
  term "bar\<^bold>[\<acute>3\<^bold>]"   term "V ''bar'' (N 3)" -- \<open>Type "\ bold [" and "\ bold ]" \<close>

  term "$a + $b"        term "Plus (V0 ''a'') (V0 ''b'')"
  term "$a + $b * $c"   term "Plus (V0 ''a'') (Times (V0 ''b'') (V0 ''c''))"
  term "($a + $b) * $c" term "Times (Plus (V0 ''a'') (V0 ''b'')) (V0 ''c'')"

  term "a\<^bold>[$i\<^bold>] + $b - $c*$d div $e mod $f"

  text \<open>Boolean Expressions\<close>
  text \<open>Idiosyncrasies:
    \<^item> Not \<open>!\<close> binds with high priority, higher than any other operator
  \<close>

  term "$a < $b"
  term "$a > $b"
  term "$a <= $b"
  term "$a >= $b"
  term "$x == $y"
  term "$x != $y"

  term "true && false"
  term "true || false"
  term "true != false"
  term "true == true"

  term "(!true == false)  = ( (!true) == false )"
  term "!(true == false)"

  text \<open>Commands\<close>
  text \<open>Idiosyncrasies:
    \<^item> Using \<open>::=\<close> for assignment, and, again, bold brackets for array indexing
  \<close>

  term "CLR x"                term "Clear ''x''"
  term "x ::= $a + \<acute>1"       term "Assign0 ''x'' (Plus (V0 ''a'') (N 1))"
  term "x\<^bold>[$i\<^bold>] ::= $a + \<acute>1"   term "Assign ''x'' (V0 ''i'') (Plus (V0 ''a'') (N 1))"

  term "x ::= $a;; y ::= $b"
  term "IF $x<\<acute>5 THEN SKIP ELSE x::=$x - \<acute>1"
  term "WHILE $x<\<acute>5 DO x::=$x + \<acute>1"

end

section \<open>Semantics\<close>

subsection \<open>States and Configuration\<close>
text \<open>
  Each variable holds an unlimited amount of values, indexed by integers
\<close>
type_synonym state = "vname \<Rightarrow> (int \<Rightarrow> val)"
type_synonym config = "com \<times> state"

text {* A little syntax magic to write larger states compactly: *}

(* All variables hold zeroes initially.
*)
definition null_state ("<>") where
  "null_state \<equiv> \<lambda>_ _. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

lemma null_state_app[simp]: "<> x = (\<lambda>_. 0)" by (auto simp: null_state_def)

text \<open>Plain variable: Value at index 0 only\<close>
definition "var x \<equiv> (\<lambda>_. 0)(0:=x)"

lemma var_idx[simp]: "var x 0 = x" by (simp add: var_def)
lemma var_subst[simp]: "(var x)(0:=y) = var y" by (simp add: var_def)
lemma var_inj[simp]: "var x = var y \<longleftrightarrow> x=y"
  unfolding var_def
  apply (auto)
  by (meson fun_upd_eqD)
lemma var_fold[simp]: "(\<lambda>_. 0)(0:=x) = var x"
  by (simp add: var_def)

(*
text \<open>Constructing a generalized array from a list\<close>
definition vlist :: "int list \<Rightarrow> int \<Rightarrow> int" where
  "vlist l i \<equiv> if 0\<le>i \<and> nat i<length l then l!nat i else 0"

lemma list_nth[simp]: "\<lbrakk>0\<le>i; nat i<length l\<rbrakk> \<Longrightarrow> vlist l i = l!nat i"
  by (auto simp: vlist_def)

lemma list_subst[simp]: "\<lbrakk> 0\<le>i; nat i<length l \<rbrakk> \<Longrightarrow> (vlist l)(i:=x) = vlist (l[nat i:=x])"
  by (auto simp: vlist_def intro!: ext)

lemma list_fold[simp]: "(\<lambda>_. 0)(0:=x) = var x"
  by (auto simp: vlist_def intro!: ext)

lemma list_inj[simp]: "length l = length l' \<Longrightarrow> vlist l = vlist l' \<longleftrightarrow> l=l'"
  apply (auto simp: vlist_def[abs_def] split: if_splits)
  by (metis (mono_tags, hide_lams) nat_int nth_equalityI of_nat_0_le_iff)
*)

definition "imap \<equiv> id"
lemma imap_app[simp]: "imap a = a" by (auto simp: imap_def)

subsection \<open>Arithmetic Expressions\<close>

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x i) s = (s x) (aval i s)" |
"aval (Binop f a1 a2) s = f (aval a1 s) (aval a2 s)"

subsection \<open>Boolean Expressions\<close>

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc v) s \<longleftrightarrow> v" |
"bval (Not b) s \<longleftrightarrow> \<not>(bval b s)" |
"bval (BBop f b1 b2) s \<longleftrightarrow> f (bval b1 s) (bval b2 s)" |
"bval (Cmpop f a1 a2) s \<longleftrightarrow> f (aval a1 s) (aval a2 s)"

subsection \<open>Big-Step\<close>

inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "(x[i] ::= a,s) \<Rightarrow> s(x := ((s x)(aval i s := aval a s)))" |
Clear: "(CLR x, s) \<Rightarrow> s(x:=(\<lambda>_. 0))" |
Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue: "\<lbrakk> bval b s; (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:
"\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3"

subsubsection \<open>Automatic Derivation\<close>
text \<open>The following is a method to execute a configuration by deriving it's big-step semantics\<close>
method Bs_simp = simp add: var_def del: var_fold
method If = (rule IfTrue, (Bs_simp;fail)) | (rule IfFalse, (Bs_simp;fail))
method While = (rule WhileTrue, (Bs_simp;fail)) | (rule WhileFalse, (Bs_simp;fail))
method BigStep = simp?; ((rule Skip Assign Seq Clear) | If | While)
method BigSteps = BigStep+

subsubsection \<open>Proof Automation Setup\<close>
declare big_step.intros [intro]

lemmas big_step_induct = big_step.induct[split_format(complete)]

inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"

inductive_cases AssignE[elim!]: "(x[i] ::= a,s) \<Rightarrow> t"
thm AssignE
inductive_cases ClearE[elim!]: "(CLR x,s) \<Rightarrow> t"
thm ClearE
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
thm IfE
inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"
thm WhileE

subsubsection \<open>Properties\<close>

text \<open>Sequential composition is associative\<close>
lemma Seq_assoc:
  "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
proof
  assume "(c1;; c2;; c3, s) \<Rightarrow> s'"
  then obtain s1 s2 where
    c1: "(c1, s) \<Rightarrow> s1" and
    c2: "(c2, s1) \<Rightarrow> s2" and
    c3: "(c3, s2) \<Rightarrow> s'" by auto
  from c2 c3
  have "(c2;; c3, s1) \<Rightarrow> s'" by (rule Seq)
  with c1
  show "(c1;; (c2;; c3), s) \<Rightarrow> s'" by (rule Seq)
next
  -- "The other direction is analogous"
  assume "(c1;; (c2;; c3), s) \<Rightarrow> s'"
  thus "(c1;; c2;; c3, s) \<Rightarrow> s'" by auto
qed

text \<open>The big-step semantics is deterministic\<close>
theorem big_step_determ: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
proof (induction arbitrary: u rule: big_step.induct)
  case (Skip s)
  then show ?case by auto
next
  case (Assign x i a s u)
  then show ?case by auto
next
  case (Clear x s)
  then show ?case by auto
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  then show ?case by blast
next
  case (IfTrue b s c\<^sub>1 t c\<^sub>2)
  from IfTrue.prems IfTrue.hyps(1) IfTrue.IH
  show ?case by auto
next
  case (IfFalse b s c\<^sub>2 t c\<^sub>1)
  from IfFalse.prems IfFalse.hyps(1) IfFalse.IH
  show ?case by auto
next
  case (WhileFalse b s c)
  then show ?case by auto
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3) then show ?case by blast
qed

subsection \<open>Small-Step\<close>

fun small_step :: "com * state \<Rightarrow> com * state" where
  "small_step (SKIP;;c\<^sub>2,s) = (c\<^sub>2,s)"
| "small_step (x[i] ::= a, s) = (SKIP, s(x := ((s x)(aval i s := aval a s))))"
| "small_step (CLR x, s) = (SKIP, s(x:=(\<lambda>_. 0)))"
| "small_step (c\<^sub>1;;c\<^sub>2,s) = (let (c\<^sub>1',s) = small_step (c\<^sub>1,s) in (c\<^sub>1';;c\<^sub>2,s))"
| "small_step (IF b THEN c1 ELSE c2, s) = (if bval b s then (c1, s) else (c2, s))"
| "small_step (WHILE b DO c,s) = (IF b THEN c;; WHILE b DO c ELSE SKIP,s)"
| "small_step (SKIP,s) = undefined"

abbreviation is_small_step (infix "\<rightarrow>" 55)
  where "is_small_step cs cs' \<equiv> fst cs \<noteq> SKIP \<and> small_step cs = cs'"

abbreviation
  small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
  where "x \<rightarrow>* y == (op \<rightarrow>)\<^sup>*\<^sup>* x y"

subsubsection{* Proof infrastructure *}

text{* The default induction rule @{thm[source] small_step.induct} only works
for lemmas of the form @{text"a \<rightarrow> b \<Longrightarrow> \<dots>"} where @{text a} and @{text b} are
not already pairs @{text"(DUMMY,DUMMY)"}. We can generate a suitable variant
of @{thm[source] small_step.induct} for pairs by ``splitting'' the arguments
@{text"\<rightarrow>"} into pairs: *}
lemmas small_step_induct = small_step.induct[split_format(complete)]

subsubsection "Equivalence with big-step semantics"

lemma ss_seq2: "(c,s) \<rightarrow> (c',s') \<Longrightarrow> (c;;cx,s) \<rightarrow> (c';;cx,s')"
  by (induction c s arbitrary: c' s' rule: small_step_induct) auto

lemma star_seq2: "(c1,s) \<rightarrow>* (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow>* (c1';;c2,s')"
  apply (induction rule: converse_rtranclp_induct2)
  apply (auto simp: ss_seq2 converse_rtranclp_into_rtranclp)
  done

lemma seq_comp:
  "\<lbrakk> (c1,s1) \<rightarrow>* (SKIP,s2); (c2,s2) \<rightarrow>* (SKIP,s3) \<rbrakk>
   \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (SKIP,s3)"
proof -
  assume a1: "(c2, s2) \<rightarrow>* (SKIP, s3)"
  assume a2: "(c1, s1) \<rightarrow>* (SKIP, s2)"
  have "(SKIP;; c2, s2) \<rightarrow>* (SKIP, s3)"
    using a1 by (simp add: converse_rtranclp_into_rtranclp)
  then have "\<And>p. p \<rightarrow>* (SKIP, s3) \<or> \<not> p \<rightarrow>* (SKIP;; c2, s2)"
    by (metis (lifting) rtranclp.rtrancl_into_rtrancl rtranclp_idemp)
  then show ?thesis
    using a2 star_seq2 by blast
qed

lemma big_to_small:
  "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
proof (induction rule: big_step.induct)
  case Skip show ?case by blast
next
  case Assign then show ?case
    by (auto intro!: r_into_rtranclp ext)
next
  case Clear then show ?case
    by (auto intro!: r_into_rtranclp ext)
next
  case Seq thus ?case by (blast intro: seq_comp)
next
  case IfTrue thus ?case
    by (auto intro: converse_rtranclp_into_rtranclp)
next
  case IfFalse thus ?case
    by (auto intro: converse_rtranclp_into_rtranclp)
next
  case WhileFalse thus ?case
    by (fastforce intro: converse_rtranclp_into_rtranclp)

next
  case WhileTrue
  thus ?case
    apply (rule_tac converse_rtranclp_into_rtranclp)
    apply simp
    apply (rule_tac converse_rtranclp_into_rtranclp)
    apply simp
    by (simp add: seq_comp)

qed

lemma small1_big_continue:
  "cs \<rightarrow> cs' \<Longrightarrow> cs' \<Rightarrow> t \<Longrightarrow> cs \<Rightarrow> t"
apply (induction arbitrary: cs' t rule: small_step.induct)
apply (auto split: prod.splits if_splits)
done

lemma small_to_big:
  "cs \<rightarrow>* (SKIP,t) \<Longrightarrow> cs \<Rightarrow> t"
apply (induction rule: converse_rtranclp_induct)
apply (auto intro: small1_big_continue)
done

text {*
  Finally, the equivalence theorem:
*}
theorem big_iff_small:
  "cs \<Rightarrow> t \<longleftrightarrow> cs \<rightarrow>* (SKIP,t)"
  using small_to_big big_to_small by blast

subsection \<open>Termination\<close>
definition "final cs \<equiv> \<nexists>cs'. cs\<rightarrow>cs'"

lemma SKIP_final[simp]: "final (c,s) \<longleftrightarrow> c=SKIP"
  by (auto simp: final_def)

section \<open>Hoare-Logic for Partial Correctness\<close>

type_synonym assn = "state \<Rightarrow> bool"

definition
hoare_valid :: "('a \<Rightarrow> assn) \<Rightarrow> com \<Rightarrow> ('a \<Rightarrow> assn) \<Rightarrow> bool" ("\<Turnstile> {(1_)}/ (_)/ {(1_)}" 50) where
"\<Turnstile> {P}c{Q} = (\<forall>s t z. P z s \<and> (c,s) \<Rightarrow> t \<longrightarrow> Q z t)"

context
  notes [simp] = hoare_valid_def
begin
  lemma hoare_validI:
    assumes "\<And>s t z. \<lbrakk> P z s; (c,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> Q z t"
    shows "\<Turnstile> {P}c{Q}"
    using assms by auto

  lemma conseq_rule:
    assumes "\<And>s z. P z s \<Longrightarrow> P' z s"
    assumes "\<Turnstile> {P'} c {Q'}"
    assumes "\<And>s z. Q' z s \<Longrightarrow> Q z s"
    shows "\<Turnstile> {P} c {Q}"
    using assms by force

  (* One-sided versions of the consequence rule *)
  lemma conseq_pre_rule:
    assumes "\<Turnstile> {P'} c {Q}"
    assumes "\<And>z s. P z s \<Longrightarrow> P' z s"
    shows "\<Turnstile> {\<lambda>z. P z} c {\<lambda>z. Q z}"
    using assms using conseq_rule by blast

  lemma conseq_post_rule:
    assumes "\<And>z s. Q z s \<Longrightarrow> Q' z s"
    assumes "\<Turnstile> {P} c {Q}"
    shows "\<Turnstile> {P} c {Q'}"
    using assms using conseq_rule by blast

  lemma skip_rule: "\<Turnstile> {P} SKIP {P}"
    by (auto)

  lemma assign_rule: "\<Turnstile> {\<lambda>z s. P z (s( x := (s x)(aval i s := aval a s) )) } x[i]::=a {P}"
    by (auto)

  lemma clear_rule: "\<Turnstile> {\<lambda>z s. P z (s( x := (\<lambda>_. 0) )) } CLR x {P}"
    by (auto)

  lemma basic_seq_rule:
    assumes "\<Turnstile> {P} c\<^sub>1 {Q}" "\<Turnstile> {Q} c\<^sub>2 {R}"
    shows "\<Turnstile> {P} c\<^sub>1;;c\<^sub>2 {R}"
    using assms by force

  definition "COND b P Q \<equiv> if b then P else Q"

  lemma if_rule:
    assumes "\<Turnstile> {P1} c\<^sub>1 {Q}" "\<Turnstile> {P2} c\<^sub>2 {Q}"
    shows "\<Turnstile> {\<lambda>z s. COND (bval b s) (P1 z s) (P2 z s)} IF b THEN c\<^sub>1 ELSE c\<^sub>2 {Q}"
    using assms unfolding COND_def by auto

  lemma basic_while_rule:
    assumes "\<Turnstile> {\<lambda>z s. P z s \<and> bval b s} c {P}"
    shows "\<Turnstile> {P} WHILE b DO c {\<lambda>z s. P z s \<and> \<not> bval b s}"
  proof (rule hoare_validI)
    fix z s t
    assume "(WHILE b DO c, s) \<Rightarrow> t" "P z s"
    then show "P z t \<and> \<not> bval b t"
    proof (induction "WHILE b DO c" s t rule: big_step_induct)
      case (WhileFalse s)
      then show ?case by simp
    next
      case (WhileTrue s\<^sub>1 s\<^sub>2 s\<^sub>3)
      note IH = \<open>P z s\<^sub>2 \<Longrightarrow> P z s\<^sub>3 \<and> \<not> bval b s\<^sub>3\<close>

      from \<open>P z s\<^sub>1\<close> \<open>bval b s\<^sub>1\<close> \<open>(c, s\<^sub>1) \<Rightarrow> s\<^sub>2\<close> \<open>\<Turnstile> {\<lambda>z s. P z s \<and> bval b s} c {P}\<close> have "P z s\<^sub>2"
        unfolding hoare_valid_def by auto
      with IH show "P z s\<^sub>3 \<and> \<not> bval b s\<^sub>3" .
    qed
  qed

  text \<open>We swap the premises of the sequence rule, as our
    verification condition generator will work on sequences
    from right to left.\<close>
  lemma seq_rule:
    assumes "\<Turnstile> {Q} c\<^sub>2 {R}" "\<Turnstile> {P} c\<^sub>1 {Q}"
    shows "\<Turnstile> {P} c\<^sub>1;;c\<^sub>2 {R}"
    using basic_seq_rule assms by blast

  text \<open>We combine the while-rule with a consequence rule, to
    make it more usable in verification condition generation\<close>

  (* Explicit backwards derivation *)
  lemma while_rule:
    assumes "\<Turnstile> {R} c {P}"
    assumes "\<And>z s. \<lbrakk>P z s; bval b s\<rbrakk> \<Longrightarrow> R z s"
    assumes "\<And>z s. \<lbrakk>P z s; \<not>bval b s\<rbrakk> \<Longrightarrow> Q z s"
    shows "\<Turnstile> {P} WHILE b DO c {Q}"
    apply (rule conseq_post_rule[where Q="\<lambda>z s. P z s \<and> \<not>bval b s"])
    apply (rule assms(3); simp)
    apply (rule basic_while_rule)
    apply (rule conseq_pre_rule)
    apply (rule assms(1))
    apply (rule assms(2); auto)
    done

end

section \<open>Hoare-Logic for Total Correctness\<close>

definition
hoaret_valid :: "('a \<Rightarrow> assn) \<Rightarrow> com \<Rightarrow> ('a \<Rightarrow> assn) \<Rightarrow> bool" ("\<Turnstile>\<^sub>t {(1_)}/ (_)/ {(1_)}" 50) where
"\<Turnstile>\<^sub>t {P}c{Q} = (\<forall>z s. P z s \<longrightarrow> (\<exists>t. (c,s) \<Rightarrow> t \<and> Q z t))"

context
  notes [simp] = hoaret_valid_def
begin
  lemma hoaret_validI:
    assumes "\<And>z s. P z s \<Longrightarrow> \<exists>t. (c,s) \<Rightarrow> t \<and> Q z t"
    shows "\<Turnstile>\<^sub>t {P}c{Q}"
    using assms by auto

  lemma conseq_trule:
    assumes "\<And>z s. P z s \<Longrightarrow> P' z s"
    assumes "\<Turnstile>\<^sub>t {P'} c {Q'}"
    assumes "\<And>z s. Q' z s \<Longrightarrow> Q z s"
    shows "\<Turnstile>\<^sub>t {P} c {Q}"
    using assms by force

  (* One-sided versions of the consequence rule *)
  lemma conseq_pre_trule:
    assumes "\<Turnstile>\<^sub>t {P'} c {Q}"
    assumes "\<And>z s. P z s \<Longrightarrow> P' z s"
    shows "\<Turnstile>\<^sub>t {\<lambda>z. P z} c {\<lambda>z. Q z}"
    using assms using conseq_trule by blast

  lemma conseq_post_trule:
    assumes "\<And>z s. Q z s \<Longrightarrow> Q' z s"
    assumes "\<Turnstile>\<^sub>t {P} c {Q}"
    shows "\<Turnstile>\<^sub>t {P} c {Q'}"
    using assms using conseq_trule by metis

  lemma skip_trule: "\<Turnstile>\<^sub>t {P} SKIP {P}"
    by (auto)

  lemma assign_trule: "\<Turnstile>\<^sub>t {\<lambda>z s. P z (s( x := (s x)(aval i s := aval a s) )) } x[i]::=a {P}"
    by (auto)

  lemma assign_trule_workaround: (* Workaround to strange unification problem *)
    assumes "\<And>z s. P z (s( x := (s x)(aval i s := aval a s))) = P' z s"
    shows "\<Turnstile>\<^sub>t {P'} Assign x i a {P}"
    using assms
    by (auto)

  lemma clear_trule: "\<Turnstile>\<^sub>t {\<lambda>z s. P z (s( x := (\<lambda>_. 0) )) } CLR x {P}"
    by (auto)

  lemma basic_seq_trule:
    assumes "\<Turnstile>\<^sub>t {P} c\<^sub>1 {Q}" "\<Turnstile>\<^sub>t {Q} c\<^sub>2 {R}"
    shows "\<Turnstile>\<^sub>t {P} c\<^sub>1;;c\<^sub>2 {R}"
    using assms by force

  lemma if_trule:
    assumes "\<Turnstile>\<^sub>t {P1} c\<^sub>1 {Q}" "\<Turnstile>\<^sub>t {P2} c\<^sub>2 {Q}"
    shows "\<Turnstile>\<^sub>t {\<lambda>z s. COND (bval b s) (P1 z s) (P2 z s)} IF b THEN c\<^sub>1 ELSE c\<^sub>2 {Q}"
    using assms unfolding COND_def by force

  lemma basic_while_trule:
    assumes WF: "wf R"
    assumes S: "\<Turnstile>\<^sub>t {\<lambda>(z,s\<^sub>0) s. P z s \<and> bval b s \<and> s=s\<^sub>0} c {\<lambda>(z,s\<^sub>0) s. P z s \<and> (s,s\<^sub>0)\<in>R}"
    shows "\<Turnstile>\<^sub>t {P} WHILE b DO c {\<lambda>z s. P z s \<and> \<not> bval b s}"
  proof (rule hoaret_validI)
    fix z s
    assume I0: "P z s"
    with WF show "\<exists>t. (WHILE b DO c, s) \<Rightarrow> t \<and> P z t \<and> \<not> bval b t"
    proof (induction s rule: wf_induct_rule)
      case (less s)
      show ?case proof (cases "bval b s")
        case True
        with S less.prems obtain s' where "(c,s) \<Rightarrow> s'" "P z s'" "(s',s)\<in>R"
          by auto
        with less.IH obtain t where "(WHILE b DO c, s') \<Rightarrow> t" "P z t" "\<not> bval b t"
          by blast
        with WhileTrue[OF True \<open>(c,s) \<Rightarrow> s'\<close>] show ?thesis by blast
      next
        case False
        with less.prems show ?thesis by auto
      qed
    qed
  qed

  text \<open>We swap the premises of the sequence rule, as our
    verification condition generator will work on sequences
    from right to left.\<close>
  lemma seq_trule:
    assumes "\<Turnstile>\<^sub>t {Q} c\<^sub>2 {R}" "\<Turnstile>\<^sub>t {P} c\<^sub>1 {Q}"
    shows "\<Turnstile>\<^sub>t {P} c\<^sub>1;;c\<^sub>2 {R}"
    using basic_seq_trule assms by blast

  text \<open>We combine the while-rule with a consequence rule, to
    make it more usable in verification condition generation\<close>

  (* Explicit backwards derivation *)
  lemma while_trule:
    assumes "wf R"
    assumes "\<Turnstile>\<^sub>t {Ph} c {\<lambda>(z,s\<^sub>0) s. P z s \<and> (s, s\<^sub>0) \<in> R}"
    assumes "\<And>z s. \<lbrakk>P z s; bval b s\<rbrakk> \<Longrightarrow> Ph (z,s) s"
    assumes "\<And>z s. \<lbrakk>P z s; \<not>bval b s\<rbrakk> \<Longrightarrow> Q z s"
    shows "\<Turnstile>\<^sub>t {\<lambda>z. P z} WHILE b DO c {\<lambda>z. Q z}"
    apply (rule conseq_post_trule[where Q="\<lambda>z s. P z s \<and> \<not>bval b s"])
    apply (rule assms; simp)
    apply (rule basic_while_trule)
    apply (rule assms)
    apply (rule conseq_pre_trule)
    apply (rule assms)
    apply clarify
    apply (rule assms; assumption)
    done

end

section \<open>Modularity\<close>
subsection \<open>Re-Using already proved specifications\<close>
lemma frame_rule_eq:
  "\<Turnstile> {P} c {Q} \<longleftrightarrow> (\<forall>R. \<Turnstile> {\<lambda>z s. \<exists>z'. P z' s \<and> (\<forall>t. Q z' t \<longrightarrow> R z t) } c {R})"
  unfolding hoare_valid_def
  by blast

lemma frame_rule:
  assumes "\<Turnstile> {P} c {Q}"
  shows "\<Turnstile> {\<lambda>z s. \<exists>z'. P z' s \<and> (\<forall>t. Q z' t \<longrightarrow> R z t) } c {R}"
  using assms frame_rule_eq by blast

lemma frame_trule_eq:
  "\<Turnstile>\<^sub>t {P} c {Q} \<longleftrightarrow> (\<forall>R. \<Turnstile>\<^sub>t {\<lambda>z s. \<exists>z'. P z' s \<and> (\<forall>t. Q z' t \<longrightarrow> R z t) } c {R})"
  unfolding hoaret_valid_def
  by blast

lemma frame_trule:
  assumes "\<Turnstile>\<^sub>t {P} c {Q}"
  shows "\<Turnstile>\<^sub>t {\<lambda>z s. \<exists>z'. P z' s \<and> (\<forall>t. Q z' t \<longrightarrow> R z t) } c {R}"
  using assms frame_trule_eq by blast

subsection \<open>Modified Variables\<close>

definition eq_on :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> bool" ("_ = _ on _" [50,50,50] 50)
  where "s=t on X \<longleftrightarrow> (\<forall>x\<in>X. s x = t x)"

lemma eq_on_subst_same[simp]:
  "x\<in>X \<Longrightarrow> s(x:=v) = t on X \<longleftrightarrow> t x = v \<and> s=t on (X-{x})"
  "x\<in>X \<Longrightarrow> s = t(x:=v) on X \<longleftrightarrow> s x = v \<and> s=t on (X-{x})"
  by (auto simp: eq_on_def)

lemma eq_on_subst_other[simp]:
  "x\<notin>X \<Longrightarrow> s(x:=v) = t on X \<longleftrightarrow> s=t on X"
  "x\<notin>X \<Longrightarrow> s = t(x:=v) on X \<longleftrightarrow> s=t on X"
  by (auto simp: eq_on_def)

lemma eq_on_refl[simp]: "s = s on X"
  by (auto simp: eq_on_def)

subsubsection \<open>Syntactic Approximation\<close>
fun lhs_vars :: "com \<Rightarrow> vname set" where
  "lhs_vars SKIP = {}"
| "lhs_vars (Clear x) = {x}"
| "lhs_vars (Assign x _ _) = {x}"
| "lhs_vars (Seq c1 c2) = lhs_vars c1 \<union> lhs_vars c2"
| "lhs_vars (If b c1 c2) = lhs_vars c1 \<union> lhs_vars c2"
| "lhs_vars (While b c) = lhs_vars c"

lemma lhs_vars_sound: "(c,s) \<Rightarrow> t \<Longrightarrow> s = t on -lhs_vars c"
  apply (induction rule: big_step_induct)
  apply (auto simp: eq_on_def)
  done

subsubsection \<open>Annotation to Hoare Triple\<close>

definition hoaret_mod_valid
  :: "('a \<Rightarrow> assn) \<Rightarrow> com \<Rightarrow> ('a \<Rightarrow> assn) \<Rightarrow> vname set \<Rightarrow> bool"
  ("\<Turnstile>\<^sub>t {(1_)}/ (_)/ {(1_)} mod _" [0,0,0,50] 50)
  where "\<Turnstile>\<^sub>t {P} c {Q} mod X \<equiv> \<Turnstile>\<^sub>t {\<lambda>(z,s\<^sub>0) s. P z s \<and> s\<^sub>0=s } c {\<lambda>(z,s\<^sub>0) t. Q z t \<and> s\<^sub>0=t on -X}"

lemma frame_mod_trule:
  assumes "\<Turnstile>\<^sub>t {P} c {Q} mod X"
  shows "\<Turnstile>\<^sub>t {\<lambda>z s. \<exists>z'. P z' s \<and> (\<forall>t. Q z' t \<and> s=t on -X \<longrightarrow> R z t) } c {R}"
  apply (rule conseq_pre_trule)
  apply (rule frame_trule)
  using assms[unfolded hoaret_mod_valid_def] apply assumption
  by auto

text \<open>Annotate Syntactic Approximation\<close>
lemma hoaret_modI:
  assumes "lhs_vars c \<subseteq> X"
  assumes "\<Turnstile>\<^sub>t {P} c {Q}"
  shows "\<Turnstile>\<^sub>t {P} c {Q} mod X"
  using assms
  using lhs_vars_sound
  unfolding hoaret_mod_valid_def hoaret_valid_def eq_on_def apply simp by fast

definition hoare_mod_valid
  :: "('a \<Rightarrow> assn) \<Rightarrow> com \<Rightarrow> ('a \<Rightarrow> assn) \<Rightarrow> vname set \<Rightarrow> bool"
  ("\<Turnstile> {(1_)}/ (_)/ {(1_)} mod _" [0,0,0,50] 50)
  where "\<Turnstile> {P} c {Q} mod X \<equiv> \<Turnstile> {\<lambda>(z,s\<^sub>0) s. P z s \<and> s\<^sub>0=s } c {\<lambda>(z,s\<^sub>0) t. Q z t \<and> s\<^sub>0=t on -X}"

lemma frame_mod_rule:
  assumes "\<Turnstile> {P} c {Q} mod X"
  shows "\<Turnstile> {\<lambda>z s. \<exists>z'. P z' s \<and> (\<forall>t. Q z' t \<and> s=t on -X \<longrightarrow> R z t) } c {R}"
  apply (rule conseq_pre_rule)
  apply (rule frame_rule)
  using assms[unfolded hoare_mod_valid_def] apply assumption
  by auto

text \<open>Annotate Syntactic Approximation\<close>
lemma hoare_modI:
  assumes "lhs_vars c \<subseteq> X"
  assumes "\<Turnstile> {P} c {Q}"
  shows "\<Turnstile> {P} c {Q} mod X"
  using assms
  using lhs_vars_sound
  unfolding hoare_mod_valid_def hoare_valid_def eq_on_def apply simp by fast

section \<open>Verification Condition Generator\<close>

subsection \<open>Simplifier Setup\<close>
  named_theorems vcg_vars_mksimps

  (* TODO: These functions may be of general interest *)
  ML \<open>
    fun eq_classes_witness _ [] = []
      | eq_classes_witness f (x::xs) = let
          val w = f x
          val (this,other) = List.partition (fn y => f y = w) xs
        in
          (w,x::this)::eq_classes_witness f other
        end

    fun gen_assoc_map l = eq_classes_witness fst l |> map (apsnd (map snd))
  \<close>

  ML \<open>

    fun add_vars_mksimps ctxt = let

      fun make_pair thm = let
        fun get_cname [Const (@{const_name Trueprop},_)$c] = get_cname [c]
          | get_cname [t$_] = get_cname [t]
          | get_cname [Const (name,_)] = SOME name
          | get_cname _ = NONE

      in
        case get_cname (Thm.prems_of thm) of
          SOME n => SOME (n,thm)
        | NONE => (
            warning ("Invalid mksimps_pair thm: " ^ @{make_string} thm); (* TODO: Pretty-print thm! *)
            NONE
        )
      end

      val thms = Named_Theorems.get ctxt @{named_theorems vcg_vars_mksimps}
      val pairs = map_filter make_pair thms |> gen_assoc_map

      val mksimps_pairs =
        pairs @ mksimps_pairs |> gen_assoc_map |> map (apsnd flat)
      val ctxt = Simplifier.set_mksimps (mksimps mksimps_pairs) ctxt

    in
      ctxt
    end

  \<close>

  method_setup vars_clarsimp = \<open>
      Scan.succeed (fn ctxt => SIMPLE_METHOD' (CHANGED_PROP o (
        let
          val ctxt = Splitter.del_split @{thm if_split} ctxt
            delsimps @{thms fun_upd_apply}
            addsimps @{thms fun_upd_same fun_upd_other}
        in
          clarsimp_tac (add_vars_mksimps ctxt)
        end
      )))
  \<close>

subsection \<open>Variable Binding\<close>
  definition vbind :: "vname \<Rightarrow> ('a \<Rightarrow> int \<Rightarrow> val) \<Rightarrow> 'a \<Rightarrow> state \<Rightarrow> bool" where "vbind x ty v s \<equiv> s x = ty v"

  definition VAR_BIND :: "vname \<Rightarrow> _ \<Rightarrow> ('a \<Rightarrow> assn) \<Rightarrow> assn" where
    "VAR_BIND x ty Q s \<equiv> \<exists>v. vbind x ty v s \<and> Q v s"
  definition VAR_CHANGED :: "(int \<Rightarrow> val) \<Rightarrow> ('a \<Rightarrow> int \<Rightarrow> val) \<Rightarrow> ('a \<Rightarrow> assn) \<Rightarrow> assn" where
    "VAR_CHANGED k ty Q s \<equiv> \<exists>v. k = ty v \<and> Q v s"

  definition EQ :: "(int \<Rightarrow> val) \<Rightarrow> ('a \<Rightarrow> int \<Rightarrow> val) \<Rightarrow> 'a \<Rightarrow> bool" where
    "EQ k ty v \<equiv> k = ty v"

  definition VAR_BIND_FINAL :: "bool \<Rightarrow> assn" where "VAR_BIND_FINAL x _ = x"
    (* Required for protection against eta-contraction on printing,
      and ensuring that final predicate does not depend on state *)

  text \<open>Variable bindings in assumptions\<close>

  lemma imapD[vcg_vars_mksimps]: "vbind x ty a s \<Longrightarrow> s x = ty a" by (auto simp: vbind_def)

  lemma eq_onD[vcg_vars_mksimps]: "a=b on X \<Longrightarrow> \<forall>x\<in>X. a x = b x"
    by (auto simp: eq_on_def)

  lemma eq_onD2[vcg_vars_mksimps]: "a=b on X \<Longrightarrow> \<forall>x\<in>X. vbind x ty v a = vbind x ty v b"
    by (auto simp: eq_on_def vbind_def)

  lemma imap_subst[simp]:
    "x\<noteq>y \<Longrightarrow> vbind x ty v (s(y:=b)) \<longleftrightarrow> vbind x ty v s"
    "vbind x ty v (s(x:=b)) \<longleftrightarrow> b = ty v"
    unfolding vbind_def by auto

  lemma VAR_BIND_elim:
    assumes "VAR_BIND x ty (\<lambda>v. Q v) s"
    obtains v where "vbind x ty v s" "Q v s"
    using assms unfolding VAR_BIND_def by auto

  lemma VAR_BIND_FINAL_elim:
    assumes "VAR_BIND_FINAL Q s"
    obtains Q using assms unfolding VAR_BIND_FINAL_def by auto

  lemmas VAR_BIND_elims = VAR_BIND_FINAL_elim VAR_BIND_elim

  text \<open>Variable Bindings in Conclusion\<close>
  text \<open>Handle substitutions\<close>

  lemma var_bind_simp1: "x\<noteq>y \<Longrightarrow> VAR_BIND x ty Q (s(y:=v)) \<longleftrightarrow> VAR_BIND x ty (\<lambda>w s. Q w (s(y:=v))) s"
    unfolding VAR_BIND_def vbind_def by auto

  lemma var_bind_simp2: "VAR_BIND x ty Q (s(x:=v)) \<longleftrightarrow> VAR_CHANGED v ty (\<lambda>w s. Q w (s(x:=v))) s"
    unfolding VAR_BIND_def VAR_CHANGED_def vbind_def by auto

  lemma var_bind_simp3: "VAR_CHANGED k ty Q (s(x:=v)) \<longleftrightarrow> VAR_CHANGED k ty (\<lambda>w s. Q w (s(x:=v))) s"
    unfolding VAR_CHANGED_def by auto

  lemma var_bind_simp4: "VAR_BIND_FINAL Q (s(x:=v)) = VAR_BIND_FINAL Q s"
    by (auto simp: VAR_BIND_FINAL_def)

  lemmas var_bind_simps = var_bind_simp1 var_bind_simp2 var_bind_simp3
    var_bind_simp4

  text \<open>Resolve Conditionals\<close>
  lemma CONDI:
    assumes "b \<Longrightarrow> P" "\<not>b \<Longrightarrow> Q"
    shows "COND b P Q"
    using assms by (auto simp: COND_def)

  text \<open>Instantiate\<close>

  lemma VAR_BINDI:
    assumes "vbind x ty v s" "Q v s"
    shows "VAR_BIND x ty Q s"
    using assms
    unfolding VAR_BIND_def VAR_CHANGED_def by auto

  lemma VAR_CHANGEDI:
    assumes "EQ k ty v" "Q v s"
    shows "VAR_CHANGED k ty Q s"
    using assms
    unfolding VAR_CHANGED_def EQ_def by auto

  lemma VAR_BIND_FINALI:
    assumes "Q"
    shows "VAR_BIND_FINAL Q s"
    using assms
    by (auto simp: VAR_BIND_FINAL_def)

  lemma EQIs:
    "EQ a imap a"
    "EQ (ty v) ty v"
    unfolding EQ_def by auto

  method vcg_resolve_binding =
    rule VAR_BINDI, assumption
  | rule VAR_CHANGEDI, rule EQIs

  method vcg_try_resolve_bindings =
    (imp_basic_simp add: var_bind_simps)?;
    (vcg_resolve_binding+)?

  method vcg_resolve_bindings = match conclusion in
    "VAR_BIND _ _ _ _" \<Rightarrow> \<open>vcg_try_resolve_bindings; (rule VAR_BIND_FINALI)\<close>
  \<bar> _ \<Rightarrow> succeed

subsubsection \<open>Syntax\<close>

(*
(* TODO: How to activate this syntax only in bundle? *)
nonterminal var_bind and var_binds

syntax
  "_var_block" :: "var_binds \<Rightarrow> 'a" ("vars _" [12] 10)
  "_var_final" :: "var_bind \<Rightarrow> 'a \<Rightarrow> var_binds" ("_ in _" [13,12] 12)
  "_var_cons" :: "var_bind \<Rightarrow> var_binds \<Rightarrow> var_binds" ("_/ _" [13,12] 12)
  "_var_bind_nvt" :: "'a \<Rightarrow> idt \<Rightarrow> 'a \<Rightarrow> var_bind" ("'(_ as _ : _')" [14,14,14] 14)
  "_var_bind_nt" :: "idt \<Rightarrow> 'a \<Rightarrow> var_bind" ("'(_ : _')" [14,14] 14)
  "_var_bind_nv" :: "'a \<Rightarrow> idt \<Rightarrow> var_bind" ("'(_ as _')" [14,14] 14)
  "_var_bind_n" :: "idt \<Rightarrow> var_bind" ("_" [14] 14)

syntax
  "_var_app" :: "var_bind \<Rightarrow> 'a \<Rightarrow> 'a"
  "_var_bind_s" :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"

translations
  "_var_block (_var_final b Q)" \<rightleftharpoons> "_var_app b (CONST VAR_BIND_FINAL Q)"
  "_var_block (_var_cons b bs)" \<rightleftharpoons> "_var_app b (_var_block bs)"
  "_var_app (_var_bind_nvt x v ty) bs" \<rightleftharpoons> "_var_bind_s x ty (\<lambda>v. bs)"
  "_var_bind_nv x v" \<rightleftharpoons> "_var_bind_nvt x v (CONST var)"
  "_var_bind_nt x ty" \<rightharpoonup> "_var_bind_nvt (x) x ty"
  "_var_bind_n x" \<rightharpoonup> "_var_bind_nv (x) x"
  "_var_cons b c" \<leftharpoondown>  "_var_final b (_var_block c)"

*)

(*syntax
  "_var_block" :: "var_binds \<Rightarrow> 'a" ("vars _" [12] 10)
  "_var_final" :: "var_bind \<Rightarrow> 'a \<Rightarrow> var_binds" ("_ in _" [13,12] 12)
  "_var_cons" :: "var_bind \<Rightarrow> var_binds \<Rightarrow> var_binds" ("_,/ _" [13,12] 12)
  "_var_bind_nvt" :: "'a \<Rightarrow> idt \<Rightarrow> 'a \<Rightarrow> var_bind" ("_ as _ : _" [14,14,14] 14)
  "_var_bind_nt" :: "idt \<Rightarrow> 'a \<Rightarrow> var_bind" ("_ : _" [14,14] 14)
  "_var_bind_nv" :: "'a \<Rightarrow> idt \<Rightarrow> var_bind" ("_ as _" [14,14] 14)
  "_var_bind_n" :: "idt \<Rightarrow> var_bind" ("_" [14] 14)
*)

(* TODO: How to activate this syntax only in bundle? *)
nonterminal var_bind and var_binds

syntax
  "_var_blockf" :: "var_binds \<Rightarrow> 'a \<Rightarrow> 'a" ("vars _ in _" [12,12] 10)
  "_var_block" :: "var_binds \<Rightarrow> 'a \<Rightarrow> 'a"
  "_var_final" :: "var_bind \<Rightarrow> var_binds" ("_" [13] 12)
  "_var_cons" :: "var_bind \<Rightarrow> var_binds \<Rightarrow> var_binds" ("_/ _" [13,12] 12)
  "_var_bind_nvt" :: "'a \<Rightarrow> idt \<Rightarrow> 'a \<Rightarrow> var_bind" ("'(_ as _ : _')" [14,14,14] 14)
  "_var_bind_nt" :: "idt \<Rightarrow> 'a \<Rightarrow> var_bind" ("'(_ : _')" [14,14] 14)
  "_var_bind_nv" :: "'a \<Rightarrow> idt \<Rightarrow> var_bind" ("'(_ as _')" [14,14] 14)
  "_var_bind_n" :: "idt \<Rightarrow> var_bind" ("_" [14] 14)

(* Syntax to output odd var-bindings, which can occur for partially unfolded var-binding blocks *)
syntax (output)
  "_var_block" :: "var_binds \<Rightarrow> 'a \<Rightarrow> 'a" ("var\<^sub>n\<^sub>o\<^sub>f\<^sub>i\<^sub>n\<^sub>a\<^sub>l _ in/ _")

syntax
  "_var_bind_s" :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"

translations
  "_var_blockf bs P" \<rightleftharpoons> "_var_block bs (CONST VAR_BIND_FINAL P)"
  "_var_block (_var_cons (_var_bind_nvt x v ty) bs) P" \<rightleftharpoons> "_var_bind_s x ty (\<lambda>v. _var_block bs P)"
  "_var_block (_var_final (_var_bind_nvt x v ty)) P" \<rightleftharpoons> "_var_bind_s x ty (\<lambda>v. P)"
  "s" \<leftharpoondown> "_var_final s"
  "_var_blockf (_var_cons b c) P" \<leftharpoondown> "_var_block b (_var_blockf c P)"

translations
  "_var_bind_nv x v" \<rightleftharpoons> "_var_bind_nvt x v (CONST var)"
  "_var_bind_nt x ty" \<rightharpoonup> "_var_bind_nvt (x) x ty"
  "_var_bind_n x" \<rightharpoonup> "_var_bind_nv (x) x"

ML \<open>
  local
    open IMP_Translation
  in
    fun xform_var_arg (Const (@{syntax_const "_constrain"}, _) $ t $ _) = xform_var_arg t
      | xform_var_arg (Free (str,_)) = SOME (HOLogic.mk_string str)
      | xform_var_arg _ = NONE

    fun
      var_bind_s_tr _ [x, ty, q] = let
        val x = the_default x (xform_var_arg x)
      in
        Syntax.const @{const_name VAR_BIND}$x$ty$q
      end
    | var_bind_s_tr _ ts = raise (TERM ("var_bind_s_tr",ts))

    fun
      var_bind_s_tr' _ (x::ts) = let
        val x = case try dest_var_syntax x of
          NONE => x
        | SOME s => Syntax.const s

      in
        list_comb (Syntax.const @{syntax_const "_var_bind_s"}, x::ts)
      end
    | var_bind_s_tr' _ _ = raise Match

    fun bound_eq (Ast.Appl [Ast.Constant @{syntax_const "_constrain"}, x, _]) y = bound_eq x y
      | bound_eq (Ast.Appl [Ast.Constant @{syntax_const "_bound"}, x]) y = bound_eq x y
      | bound_eq (Ast.Variable x) y = x = y
      | bound_eq _ _ = false

    fun var_same_ast_tr' [(Ast.Constant x), b] =
      if bound_eq b x then
        Ast.Appl [Ast.Constant @{syntax_const "_var_bind_n"}, b]
      else raise Match
    | var_same_ast_tr' [(Ast.Constant x), b, ty] =
      if bound_eq b x then
        Ast.Appl [Ast.Constant @{syntax_const "_var_bind_nt"}, b, ty]
      else raise Match
    | var_same_ast_tr' _ = raise Match

    val setup =
      Sign.parse_translation [
          (@{syntax_const "_var_bind_s"}, var_bind_s_tr)
        ]
      #>
      Sign.print_translation [
        (@{const_syntax VAR_BIND}, var_bind_s_tr')
      ]
      #>
    Sign.print_ast_translation
     [(@{syntax_const "_var_bind_nvt"}, K var_same_ast_tr'),
      (@{syntax_const "_var_bind_nv"}, K var_same_ast_tr')
     ];

    val _ = Theory.setup setup

  end
\<close>

lemma "(vars a b c in P a b c) s"
  unfolding VAR_BIND_FINAL_def
  oops

lemma "XP (vars a (b : var) c (x as xx) (''xx.d'' as xxx) (''__y'' as yy : id) in P a b c)"
  unfolding VAR_BIND_FINAL_def
  oops

subsection \<open>Annotating While Loops\<close>
definition AWHILE :: "('a \<Rightarrow> assn) \<Rightarrow> bexp \<Rightarrow> com \<Rightarrow> com" ("(INVAR (_)/ WHILE (\<open>unbreakable\<close>_) DO(2/ _))"  [0, 0, 61] 61)
  where "INVAR I WHILE b DO c \<equiv> WHILE b DO c"

lemma annot_invar: "(WHILE b DO c) = (INVAR I WHILE b DO c)" by (simp add: AWHILE_def)

lemma awhile_rule:
  assumes "\<Turnstile> {R} c {P}"
  assumes "\<And>z s. \<lbrakk>P z s; bval b s\<rbrakk> \<Longrightarrow> R z s"
  assumes "\<And>z s. \<lbrakk>P z s; \<not>bval b s\<rbrakk> \<Longrightarrow> Q z s"
  shows "\<Turnstile> {P} INVAR P WHILE b DO c {Q}"
  unfolding AWHILE_def by (rule while_rule[OF assms])

definition AWHILET :: "(state\<times>state) set \<Rightarrow> ('a \<Rightarrow> assn) \<Rightarrow> bexp \<Rightarrow> com \<Rightarrow> com" ("(VAR (_)/ INVAR (_)/ WHILE (\<open>unbreakable\<close>_) DO(2/ _))"  [0, 0, 0, 61] 61)
  where "VAR R INVAR I WHILE b DO c \<equiv> WHILE b DO c"

lemma annot_tinvar: "(WHILE b DO c) = (VAR R INVAR I WHILE b DO c)" by (simp add: AWHILET_def)

lemma awhile_trule:
  fixes R :: "(state \<times> state) set"
  assumes "wf R"
  assumes "\<Turnstile>\<^sub>t {Ph} c {\<lambda>(z,s\<^sub>0) s. P z s \<and> (s, s\<^sub>0) \<in> R}"
  assumes "\<And>z s. \<lbrakk>P z s; bval b s\<rbrakk> \<Longrightarrow> id Ph (z,s) s"
  assumes "\<And>z s. \<lbrakk>P z s; \<not>bval b s\<rbrakk> \<Longrightarrow> Q z s"
  shows "\<Turnstile>\<^sub>t {\<lambda>z. P z} VAR R INVAR P WHILE b DO c {\<lambda>z. Q z}"
  unfolding AWHILET_def
  by (rule while_trule[OF assms[simplified]])

lemma lhs_vars_awhile[simp]:
  "lhs_vars (INVAR I WHILE b DO c) = lhs_vars c"
  "lhs_vars (VAR R INVAR I WHILE b DO c) = lhs_vars c"
  unfolding AWHILE_def AWHILET_def by auto

text \<open>Measure function by aexp\<close>
abbreviation "measure_exp a \<equiv> measure (nat o aval a)"

subsection \<open>Basic VCG\<close>

named_theorems vcg_rules

lemmas [vcg_rules] =
  skip_rule assign_rule clear_rule seq_rule if_rule awhile_rule
  skip_trule assign_trule clear_trule seq_trule if_trule awhile_trule conjI

named_theorems vcg_init_rules
lemmas [vcg_init_rules] = conseq_pre_rule conseq_pre_trule

method vcg_is_no_hoare_triple = match conclusion in
    "\<Turnstile> {_} _ {_}" \<Rightarrow> fail
  \<bar> "\<Turnstile>\<^sub>t {_} _ {_}" \<Rightarrow> fail
  \<bar> _ \<Rightarrow> succeed

definition VERIFICATION_CONDITION :: "bool \<Rightarrow> bool" where
  "VERIFICATION_CONDITION P = P"

lemma VC_I: "P \<Longrightarrow> VERIFICATION_CONDITION P" by (simp add: VERIFICATION_CONDITION_def)
lemma VC_D: "VERIFICATION_CONDITION P \<Longrightarrow> P" by (simp add: VERIFICATION_CONDITION_def)

method vcg_rule_wrapper methods m = m; (vcg_is_no_hoare_triple, rule VC_D)?

method vcg_rule (* Apply Hoare-rule and tag side conditions *)
  = vcg_rule_wrapper\<open>rule vcg_rules | rule frame_mod_rule frame_mod_trule, rule vcg_rules\<close>

lemma redundant_vbindE:
  assumes "vbind x ty v1 s" "vbind x ty v2 s"
  obtains "ty v1 = ty v2"
  using assms by (auto simp: vbind_def)

method_setup vcg_redundant_vbind = \<open>
 Scan.succeed (fn ctxt => SIMPLE_METHOD (
   REPEAT_DETERM1 (FIRSTGOAL (EVERY' [eresolve_tac ctxt @{thms redundant_vbindE}, assume_tac ctxt]))
 ))\<close>

method vcg_prepare_goal -- \<open>Applied before processing any goal\<close>
  = (elim VAR_BIND_elims conjE)?;((vars_clarsimp| vcg_redundant_vbind)+)?

lemma thin_imap: "vbind x ty v s \<Longrightarrow> P \<Longrightarrow> P" .
lemma thin_eqon: "(s::state) = t on X \<Longrightarrow> P \<Longrightarrow> P" .

method_setup vcg_remove_binding_assms = \<open>
 Scan.succeed (fn ctxt => SIMPLE_METHOD (
   REPEAT_DETERM (FIRSTGOAL (eresolve_tac ctxt @{thms thin_imap thin_eqon}))
 ))\<close>

(*method vcg_remove_binding_assms = ((thin_tac "imap _ _ _ _")+)?*)

definition "MOD_VAR_APPROX A B \<equiv> A\<subseteq>B"
lemma MOD_VAR_APPROXI: "A\<subseteq>B \<Longrightarrow> MOD_VAR_APPROX A B"
  by (auto simp: MOD_VAR_APPROX_def)

lemma hoaret_modI_vcg:
  assumes "MOD_VAR_APPROX (lhs_vars c) X"
  assumes "\<Turnstile>\<^sub>t {P} c {Q}"
  shows "\<Turnstile>\<^sub>t {P} c {Q} mod X"
  using assms hoaret_modI unfolding MOD_VAR_APPROX_def by blast

lemma hoare_modI_vcg:
  assumes "MOD_VAR_APPROX (lhs_vars c) X"
  assumes "\<Turnstile> {P} c {Q}"
  shows "\<Turnstile> {P} c {Q} mod X"
  using assms hoare_modI unfolding MOD_VAR_APPROX_def by blast

lemmas [vcg_init_rules] =
  hoaret_modI_vcg[OF _ conseq_pre_trule]
  hoare_modI_vcg[OF _ conseq_pre_rule]

method solve_mod_var_approx = (rule MOD_VAR_APPROXI; auto; fail)

definition "INST_VARS X \<equiv> True"

lemma INST_VARS_I:
  "INST_VARS P \<Longrightarrow> INST_VARS Q \<Longrightarrow> INST_VARS (P\<and>Q)"
  "INST_VARS (x = x)"
  by (auto simp add: INST_VARS_def)

lemma INST_VARS_rem: "INST_VARS X" by (auto simp add: INST_VARS_def)

lemma INST_VARS_begin:
  "INST_VARS P \<Longrightarrow> P \<Longrightarrow> P" .

method vcg_inst_vars =
    rule INST_VARS_begin,
    (((rule INST_VARS_I | rule INST_VARS_rem)+) [])

method vcg_prepare_vc -- \<open>Applied to prepare verification condition. May solve it.\<close>
  = rule VC_I;(intro conjI impI allI CONDI exI)?;vcg_prepare_goal; (vcg_resolve_bindings; vcg_remove_binding_assms | vcg_try_resolve_bindings); vcg_inst_vars

method vcgdbg_prepare_vc -- \<open>Applied to prepare verification condition. May solve it.\<close>
  = rule VC_I;(intro conjI impI allI CONDI exI)?;vcg_prepare_goal; (vcg_resolve_bindings | vcg_try_resolve_bindings); vcg_inst_vars

method vcg_step_solver methods solver
  = vcg_prepare_goal; ( vcg_rule | vcg_prepare_vc;solver )
method vcg_default_solver = clarsimp?; (safe?;clarsimp?;simp?;solve_mod_var_approx?;fail)?

method vcgdbg_step_solver methods solver
  = vcg_prepare_goal; ( vcg_rule | vcgdbg_prepare_vc;solver )

method vcg_step = vcg_step_solver\<open>vcg_default_solver\<close>
method vcg_ctd = (vcg_step)+

method vcgdbg_step = vcgdbg_step_solver\<open>vcg_default_solver\<close>
method vcgdbg_ctd = (vcgdbg_step)+

method vcg_init = vcg_rule_wrapper\<open>rule vcg_init_rules\<close>

method vcg = vcg_init, vcg_ctd

method vcg_ctd_raw = (vcg_step_solver\<open>succeed\<close>)+
method vcg_raw = vcg_init, vcg_ctd_raw

subsection \<open>Deferred VCs\<close>

definition DEFERRED :: "bool \<Rightarrow> bool" where "DEFERRED P = P"
lemma DEFERREDD: "DEFERRED P \<Longrightarrow> P" by (auto simp: DEFERRED_def)

method vcg_can_defer =
  (
    match conclusion
      in "DEFERRED _" \<Rightarrow> fail -- \<open>Refuse to defer already deferred goals\<close>
    \<bar> "\<Turnstile> {_} _ {_}" \<Rightarrow> fail  -- \<open>Refuse to defer Hoare triples (They are no VCs!)\<close>
    \<bar> "\<Turnstile>\<^sub>t {_} _ {_}" \<Rightarrow> fail  -- \<open>Refuse to defer Hoare triples (They are no VCs!)\<close>
    \<bar> _ \<Rightarrow> succeed)

method vcg_defer =
  vcg_can_defer, rule DEFERREDD, tactic \<open>FIRSTGOAL defer_tac\<close>

method vcg_all =
  (vcg_init, (vcg_ctd, vcg_defer? | vcg_defer)+, (unfold DEFERRED_def)?)

end


section \<open>Finding a Path between Nodes\<close>
theory DFS_Find_Path
imports
  "../DFS_Framework"
  CAVA_Automata.Digraph_Impl
  "../Misc/Impl_Rev_Array_Stack"
begin
text \<open>
  We instantiate the DFS framework to find a path to some reachable node
  that satisfies a given predicate. We present four variants of the algorithm:
  Finding any path, and finding path of at least length one, combined with
  searching the whole graph, and searching the graph restricted to a given set
  of nodes. The restricted variants are efficiently implemented by
  pre-initializing the visited set (cf. @{theory DFS_Framework.Restr_Impl}).

  The restricted variants can be used for incremental search, ignoring already
  searched nodes in further searches. This is required, e.g., for the inner
  search of nested DFS (Buchi automaton emptiness check).
\<close>

subsection \<open>Including empty Path\<close>
record 'v fp0_state = "'v state" +
  ppath :: "('v list \<times> 'v) option"

type_synonym 'v fp0_param = "('v, ('v,unit) fp0_state_ext) parameterization"

abbreviation "no_path \<equiv> \<lparr> ppath = None \<rparr>"
abbreviation "a_path p v \<equiv> \<lparr> ppath = Some (p,v) \<rparr>"

definition fp0_params :: "('v \<Rightarrow> bool) \<Rightarrow> 'v fp0_param"
  where "fp0_params P \<equiv> \<lparr>
  on_init = RETURN no_path,
  on_new_root = \<lambda>v0 s. if P v0 then RETURN (a_path [] v0) else RETURN no_path,
  on_discover = \<lambda>u v s. if P v
                   then \<comment> \<open>\<open>v\<close> is already on the stack, so we need to pop it again\<close>
                      RETURN (a_path (rev (tl (stack s))) v)
                   else RETURN no_path,
  on_finish = \<lambda>u s. RETURN (state.more s),
  on_back_edge = \<lambda>u v s. RETURN (state.more s),
  on_cross_edge = \<lambda>u v s. RETURN (state.more s),
  is_break = \<lambda>s. ppath s \<noteq> None \<rparr>"

lemmas fp0_params_simps[simp]
  = gen_parameterization.simps[mk_record_simp, OF fp0_params_def]

interpretation fp0: param_DFS_defs where param = "fp0_params P"
  for G P .

locale fp0 = param_DFS G "fp0_params P"
  for G and P :: "'v \<Rightarrow> bool"
begin

  lemma [simp]:
    "ppath (empty_state \<lparr>ppath = e\<rparr>) = e"
    by (simp add: empty_state_def)

  lemma [simp]:
    "ppath (s\<lparr>state.more := state.more s'\<rparr>) = ppath s'"
    by (cases s, cases s') auto

  sublocale DFS where param = "fp0_params P"
    by unfold_locales simp_all

end

lemma fp0I: assumes "fb_graph G" shows "fp0 G"
proof - interpret fb_graph G by fact show ?thesis by unfold_locales qed

locale fp0_invar = fp0 +
  DFS_invar where param = "fp0_params P"

lemma fp0_invar_eq[simp]:
  "DFS_invar G (fp0_params P) = fp0_invar G P"
proof (intro ext iffI)
  fix s
  assume "DFS_invar G (fp0_params P) s"
  interpret DFS_invar G "fp0_params P" s by fact
  show "fp0_invar G P s" by unfold_locales
next
  fix s
  assume "fp0_invar G P s"
  interpret fp0_invar G P s by fact
  show "DFS_invar G (fp0_params P) s" by unfold_locales
qed

context fp0 begin

  lemma i_no_path_no_P_discovered:
    "is_invar (\<lambda>s. ppath s = None \<longrightarrow> dom (discovered s) \<inter> Collect P = {})"
  by (rule establish_invarI) simp_all

  lemma i_path_to_P:
    "is_invar (\<lambda>s. ppath s = Some (vs,v) \<longrightarrow> P v)"
  by (rule establish_invarI) auto

  lemma i_path_invar:
    "is_invar (\<lambda>s. ppath s = Some (vs,v) \<longrightarrow>
                   (vs \<noteq> [] \<longrightarrow> hd vs \<in> V0 \<and> path E (hd vs) vs v)
                 \<and> (vs = [] \<longrightarrow> v \<in> V0 \<and> path E v vs v)
                 \<and> (distinct (vs@[v]))
                 )"
  proof (induct rule: establish_invarI)
    case (discover s s' u v) then interpret fp0_invar where s=s
      by simp

    from discover have ne: "stack s \<noteq> []" by simp
    from discover have vnis: "v\<notin>set (stack s)" using stack_discovered by auto

    from pendingD discover have "v \<in> succ (hd (stack s))" by simp
    with hd_succ_stack_is_path[OF ne] have "\<exists>v0\<in>V0. path E v0 (rev (stack s)) v" .
    moreover from last_stack_in_V0 ne have "last (stack s) \<in> V0" by simp
    ultimately have "path E (hd (rev (stack s)))  (rev (stack s)) v" "hd (rev (stack s)) \<in> V0"
      using hd_rev[OF ne] path_hd[where p="rev (stack s)"] ne
      by auto
    with ne discover vnis show ?case by (auto simp: stack_distinct)
  qed auto
end

context fp0_invar
begin
  lemmas no_path_no_P_discovered
    = i_no_path_no_P_discovered[THEN make_invar_thm, rule_format]

  lemmas path_to_P
    = i_path_to_P[THEN make_invar_thm, rule_format]

  lemmas path_invar
    = i_path_invar[THEN make_invar_thm, rule_format]

  lemma path_invar_nonempty:
    assumes "ppath s = Some (vs,v)"
    and "vs \<noteq> []"
    shows "hd vs \<in> V0" "path E (hd vs) vs v"
    using assms path_invar
    by auto

  lemma path_invar_empty:
    assumes "ppath s = Some (vs,v)"
    and "vs = []"
    shows "v \<in> V0" "path E v vs v"
    using assms path_invar
    by auto

  lemma fp0_correct:
    assumes "\<not>cond s"
    shows "case ppath s of
      None \<Rightarrow> \<not>(\<exists>v0\<in>V0. \<exists>v. (v0,v) \<in> E\<^sup>* \<and> P v)
    | Some (p,v) \<Rightarrow> (\<exists>v0\<in>V0. path E v0 p v \<and> P v \<and> distinct (p@[v]))"
  proof (cases "ppath s")
    case None with assms nc_discovered_eq_reachable no_path_no_P_discovered have
      "reachable \<inter> Collect P = {}" by auto
    thus ?thesis by (auto simp add: None)
  next
    case (Some vvs) then obtain v vs where [simp]: "vvs = (vs,v)"
      by (cases vvs) auto

    from Some path_invar[of vs v] path_to_P[of _ v] show ?thesis
      by auto
  qed

end

context fp0 begin
  lemma fp0_correct: "it_dfs \<le> SPEC (\<lambda>s. case ppath s of
      None \<Rightarrow> \<not>(\<exists>v0\<in>V0. \<exists>v. (v0,v) \<in> E\<^sup>* \<and> P v)
    | Some (p,v) \<Rightarrow> (\<exists>v0\<in>V0. path E v0 p v \<and> P v \<and> distinct (p@[v])))"
    apply (rule weaken_SPEC[OF it_dfs_correct])
    apply clarsimp
    apply (simp add: fp0_invar.fp0_correct)
    done
end

subsubsection \<open>Basic Interface\<close>
text \<open>Use this interface, rather than the internal stuff above! \<close>
(* Making it a well-defined interface. This interface should be used, not
  the internal stuff. If more information about the result is needed, this
  interface should be extended! *)

type_synonym 'v fp_result = "('v list \<times> 'v) option"
definition "find_path0_pred G P \<equiv> \<lambda>r. case r of
    None \<Rightarrow> (g_E G)\<^sup>* `` g_V0 G \<inter> Collect P = {}
  | Some (vs,v) \<Rightarrow> P v \<and> distinct (vs@[v]) \<and> (\<exists> v0 \<in> g_V0 G. path (g_E G) v0 vs v)"

definition find_path0_spec
  :: "('v, _) graph_rec_scheme \<Rightarrow> ('v \<Rightarrow> bool) \<Rightarrow> 'v fp_result nres"
  \<comment> \<open>Searches a path from the root nodes to some target node that satisfies a
      given predicate. If such a path is found, the path and the target node
      are returned\<close>
where
  "find_path0_spec G P \<equiv> do {
    ASSERT (fb_graph G);
    SPEC (find_path0_pred G P)
  }"

definition find_path0
  :: "('v, 'more) graph_rec_scheme \<Rightarrow> ('v \<Rightarrow> bool) \<Rightarrow> 'v fp_result nres"
  where "find_path0 G P \<equiv> do {
  ASSERT (fp0 G);
  s \<leftarrow> fp0.it_dfs TYPE('more) G P;
  RETURN (ppath s)
}"

lemma find_path0_correct:
  shows "find_path0 G P \<le> find_path0_spec G P"
  unfolding find_path0_def find_path0_spec_def find_path0_pred_def
  apply (refine_vcg le_ASSERTI order_trans[OF fp0.fp0_correct])
  apply (erule fp0I)
  apply (auto split: option.split) []
  done

lemmas find_path0_spec_rule[refine_vcg] =
  ASSERT_le_defI[OF find_path0_spec_def]
  ASSERT_leof_defI[OF find_path0_spec_def]

subsection \<open>Restricting the Graph\<close>
text \<open> Extended interface, propagating set of already searched nodes (restriction) \<close>
(* Invariant for restriction: The restriction is closed under E
  and contains no P-nodes *)
definition restr_invar
  \<comment> \<open>Invariant for a node restriction, i.e., a transition closed set of nodes
    known to not contain a target node that satisfies a predicate.\<close>
  where
  "restr_invar E R P \<equiv> E `` R \<subseteq> R \<and> R \<inter> Collect P = {}"

lemma restr_invar_triv[simp, intro!]: "restr_invar E {} P"
  unfolding restr_invar_def by simp

lemma restr_invar_imp_not_reachable: "restr_invar E R P \<Longrightarrow> E\<^sup>*``R \<inter> Collect P = {}"
  unfolding restr_invar_def by (simp add: Image_closed_trancl)

type_synonym 'v fpr_result = "'v set + ('v list \<times> 'v)"
definition "find_path0_restr_pred G P R \<equiv> \<lambda>r.
    case r of
      Inl R' \<Rightarrow> R' = R \<union> (g_E G)\<^sup>* `` g_V0 G \<and> restr_invar (g_E G) R' P
    | Inr (vs,v) \<Rightarrow> P v \<and> (\<exists> v0 \<in> g_V0 G - R. path (rel_restrict (g_E G) R) v0 vs v)"

definition find_path0_restr_spec
  \<comment> \<open>Find a path to a target node that satisfies a predicate, not considering
      nodes from the given node restriction. If no path is found, an extended
      restriction is returned, that contains the start nodes\<close>
  where "find_path0_restr_spec G P R \<equiv> do {
    ASSERT (fb_graph G \<and> restr_invar (g_E G) R P);
    SPEC (find_path0_restr_pred G P R)}"

lemmas find_path0_restr_spec_rule[refine_vcg] =
  ASSERT_le_defI[OF find_path0_restr_spec_def]
  ASSERT_leof_defI[OF find_path0_restr_spec_def]

definition find_path0_restr
  :: "('v, 'more) graph_rec_scheme \<Rightarrow> ('v \<Rightarrow> bool) \<Rightarrow> 'v set \<Rightarrow> 'v fpr_result nres"
  where "find_path0_restr G P R \<equiv> do {
  ASSERT (fb_graph G);
  ASSERT (fp0 (graph_restrict G R));
  s \<leftarrow> fp0.it_dfs TYPE('more) (graph_restrict G R) P;
  case ppath s of
    None \<Rightarrow> do {
      ASSERT (dom (discovered s) = dom (finished s));
      RETURN (Inl (R \<union> dom (finished s)))
    }
  | Some (vs,v) \<Rightarrow> RETURN (Inr (vs,v))
}"

lemma find_path0_restr_correct:
  shows "find_path0_restr G P R \<le> find_path0_restr_spec G P R"
proof (rule le_ASSERT_defI1[OF find_path0_restr_spec_def], clarify)
  assume "fb_graph G"
  interpret a: fb_graph G by fact
  interpret fb_graph "graph_restrict G R" by (rule a.fb_graph_restrict)

  assume I: "restr_invar (g_E G) R P"

  define reachable where "reachable = graph_defs.reachable (graph_restrict G R)"

  interpret fp0 "graph_restrict G R" by unfold_locales

  show ?thesis unfolding find_path0_restr_def find_path0_restr_spec_def
    apply (refine_rcg refine_vcg le_ASSERTI order_trans[OF it_dfs_correct])
    apply unfold_locales
    apply (clarsimp_all)
  proof -
    fix s
    assume "fp0_invar (graph_restrict G R) P s"
      and NC[simp]: "\<not>fp0.cond TYPE('b) (graph_restrict G R) P s"
    then interpret fp0_invar "graph_restrict G R" P s by simp

    {
      assume [simp]: "ppath s = None"

      from nc_discovered_eq_finished
      show "dom (discovered s) = dom (finished s)" by simp

      from nc_finished_eq_reachable
      have DFR[simp]: "dom (finished s) = reachable"
        by (simp add: reachable_def)

      from I have "g_E G `` R \<subseteq> R" unfolding restr_invar_def by auto

      have "reachable \<subseteq> (g_E G)\<^sup>* `` g_V0 G"
        unfolding reachable_def
        by (rule Image_mono, rule rtrancl_mono) (auto simp: rel_restrict_def)

      hence "R \<union> dom (finished s) = R \<union> (g_E G)\<^sup>* `` g_V0 G"
        apply -
        apply (rule equalityI)
        apply auto []
        unfolding DFR reachable_def
        apply (auto elim: E_closed_restr_reach_cases[OF _ \<open>g_E G `` R \<subseteq> R\<close>]) []
        done
      moreover from nc_fin_closed I
      have "g_E G `` (R \<union> dom (finished s)) \<subseteq> R \<union> dom (finished s)"
        unfolding restr_invar_def by (simp add: rel_restrict_def) blast
      moreover from no_path_no_P_discovered nc_discovered_eq_finished I
      have "(R \<union> dom (finished s)) \<inter> Collect P = {}"
        unfolding restr_invar_def by auto
      ultimately
      show "find_path0_restr_pred G P R (Inl (R \<union> dom (finished s)))"
        unfolding restr_invar_def find_path0_restr_pred_def by auto
    }

    {
      fix v vs
      assume [simp]: "ppath s = Some (vs,v)"
      from fp0_correct
      show "find_path0_restr_pred G P R (Inr (vs, v))"
        unfolding find_path0_restr_pred_def by auto
    }
  qed
qed

subsection \<open>Path of Minimal Length One, with Restriction\<close>
definition "find_path1_restr_pred G P R \<equiv> \<lambda>r.
      case r of
        Inl R' \<Rightarrow> R' = R \<union> (g_E G)\<^sup>+ `` g_V0 G \<and> restr_invar (g_E G) R' P
      | Inr (vs,v) \<Rightarrow> P v \<and> vs \<noteq> [] \<and> (\<exists> v0 \<in> g_V0 G. path (g_E G \<inter> UNIV \<times> -R) v0 vs v)"

definition find_path1_restr_spec
  \<comment> \<open>Find a path of length at least one to a target node that satisfies P.
    Takes an initial node restriction, and returns an extended node restriction.\<close>
  where "find_path1_restr_spec G P R \<equiv> do {
    ASSERT (fb_graph G \<and> restr_invar (g_E G) R P);
    SPEC (find_path1_restr_pred G P R)}"

lemmas find_path1_restr_spec_rule[refine_vcg] =
  ASSERT_le_defI[OF find_path1_restr_spec_def]
  ASSERT_leof_defI[OF find_path1_restr_spec_def]

definition find_path1_restr
  :: "('v, 'more) graph_rec_scheme \<Rightarrow> ('v \<Rightarrow> bool) \<Rightarrow> 'v set \<Rightarrow> 'v fpr_result nres"
  where "find_path1_restr G P R \<equiv>
  FOREACHc (g_V0 G) is_Inl (\<lambda>v0 s. do {
    ASSERT (is_Inl s); \<comment> \<open>TODO: Add FOREACH-condition as precondition in autoref!\<close>
    let R = projl s;
    f0 \<leftarrow> find_path0_restr_spec (G \<lparr> g_V0 := g_E G `` {v0} \<rparr>) P R;
    case f0 of
      Inl _ \<Rightarrow> RETURN f0
    | Inr (vs,v) \<Rightarrow> RETURN (Inr (v0#vs,v))
  }) (Inl R)"

definition "find_path1_tailrec_invar G P R0 it s \<equiv>
  case s of
    Inl R \<Rightarrow> R = R0 \<union> (g_E G)\<^sup>+ `` (g_V0 G - it) \<and> restr_invar (g_E G) R P
  | Inr (vs, v) \<Rightarrow> P v \<and> vs \<noteq> [] \<and> (\<exists> v0 \<in> g_V0 G - it. path (g_E G \<inter> UNIV \<times> -R0) v0 vs v)"

lemma find_path1_restr_correct:
  shows "find_path1_restr G P R \<le> find_path1_restr_spec G P R"
proof (rule le_ASSERT_defI1[OF find_path1_restr_spec_def], clarify)
  assume "fb_graph G"
  interpret a: fb_graph G by fact
  interpret fb0: fb_graph "G \<lparr> g_E := g_E G \<inter> UNIV \<times> -R \<rparr>"
    by (rule a.fb_graph_subset, auto)

  assume I: "restr_invar (g_E G) R P"

  have aux2: "\<And>v0. v0 \<in> g_V0 G \<Longrightarrow> fb_graph (G \<lparr> g_V0 := g_E G `` {v0} \<rparr>)"
    by (rule a.fb_graph_subset, auto)

  {
    fix v0 it s
    assume IT: "it \<subseteq> g_V0 G" "v0 \<in> it"
    and "is_Inl s"
    and FPI: "find_path1_tailrec_invar G P R it s"
    and RI: "restr_invar (g_E G) (projl s \<union> (g_E G)\<^sup>+ `` {v0}) P"

    then obtain R' where [simp]: "s = Inl R'" by (cases s) auto

    from FPI have [simp]: "R' = R \<union> (g_E G)\<^sup>+ `` (g_V0 G - it)"
      unfolding find_path1_tailrec_invar_def by simp

    have "find_path1_tailrec_invar G P R (it - {v0})
            (Inl (projl s \<union> (g_E G)\<^sup>+ `` {v0}))"
      using RI
      by (auto simp: find_path1_tailrec_invar_def it_step_insert_iff[OF IT])
  } note aux4 = this

  {
    fix v0 u it s v p
    assume IT: "it \<subseteq> g_V0 G" "v0 \<in> it"
    and "is_Inl s"
    and FPI: "find_path1_tailrec_invar G P R it s"
    and PV: "P v"
    and PATH: "path (rel_restrict (g_E G) (projl s)) u p v" "(v0,u)\<in>(g_E G)"
    and PR: "u \<notin> projl s"

    then obtain R' where [simp]: "s = Inl R'" by (cases s) auto

    from FPI have [simp]: "R' = R \<union> (g_E G)\<^sup>+ `` (g_V0 G - it)"
      unfolding find_path1_tailrec_invar_def by simp

    have "find_path1_tailrec_invar G P R (it - {v0}) (Inr (v0 # p, v))"
      apply (simp add: find_path1_tailrec_invar_def PV)
      apply (rule bexI[where x=v0])
        using PR PATH(2) path_mono[OF rel_restrict_mono2[of R] PATH(1)]
        apply (auto simp: path1_restr_conv) []

        using IT apply blast
      done
  } note aux5 = this

  show ?thesis
    unfolding find_path1_restr_def find_path1_restr_spec_def find_path1_restr_pred_def
    apply (refine_rcg le_ASSERTI
      refine_vcg FOREACHc_rule[where I="find_path1_tailrec_invar G P R"]
      (*order_trans[OF find_path0_restr_correct]*)
      )
    apply simp
    using I apply (auto simp add: find_path1_tailrec_invar_def restr_invar_def) []

    apply (blast intro: aux2)
    apply (auto simp add: find_path1_tailrec_invar_def split: sum.splits) []
    apply (auto
      simp: find_path0_restr_pred_def aux4 aux5
      simp: trancl_Image_unfold_left[symmetric]
      split: sum.splits) []

    apply (auto simp add: find_path1_tailrec_invar_def split: sum.splits) [2]
    done
qed

definition "find_path1_pred G P \<equiv> \<lambda>r.
      case r of
        None \<Rightarrow> (g_E G)\<^sup>+ `` g_V0 G \<inter> Collect P = {}
      | Some (vs, v) \<Rightarrow> P v \<and> vs \<noteq> [] \<and> (\<exists> v0 \<in> g_V0 G. path (g_E G) v0 vs v)"
definition find_path1_spec
  \<comment> \<open>Find a path of length at least one to a target node that satisfies
      a given predicate.\<close>
  where "find_path1_spec G P \<equiv> do {
    ASSERT (fb_graph G);
    SPEC (find_path1_pred G P)}"

lemmas find_path1_spec_rule[refine_vcg] =
  ASSERT_le_defI[OF find_path1_spec_def]
  ASSERT_leof_defI[OF find_path1_spec_def]

subsection \<open>Path of Minimal Length One, without Restriction\<close>
definition find_path1
  :: "('v, 'more) graph_rec_scheme \<Rightarrow> ('v \<Rightarrow> bool) \<Rightarrow> 'v fp_result nres"
  where "find_path1 G P \<equiv> do {
  r \<leftarrow> find_path1_restr_spec G P {};
  case r of
    Inl _ \<Rightarrow> RETURN None
  | Inr vsv \<Rightarrow> RETURN (Some vsv)
}"

lemma find_path1_correct:
  shows "find_path1 G P \<le> find_path1_spec G P"
  unfolding find_path1_def find_path1_spec_def find_path1_pred_def
  apply (refine_rcg refine_vcg le_ASSERTI order_trans[OF find_path1_restr_correct])
  apply simp
  apply (fastforce
    simp: find_path1_restr_spec_def find_path1_restr_pred_def
    split: sum.splits
    dest!: restr_invar_imp_not_reachable tranclD)
  done

subsection \<open>Implementation\<close>

(* Implementation with stack *)
record 'v fp0_state_impl = "'v simple_state" +
  ppath :: "('v list \<times> 'v) option"

definition "fp0_erel \<equiv> {
  (\<lparr> fp0_state_impl.ppath = p \<rparr>, \<lparr> fp0_state.ppath = p\<rparr>) | p. True }"

abbreviation "fp0_rel R \<equiv> \<langle>fp0_erel\<rangle>restr_simple_state_rel R"

abbreviation "no_path_impl \<equiv> \<lparr> fp0_state_impl.ppath = None \<rparr>"
abbreviation "a_path_impl p v \<equiv> \<lparr> fp0_state_impl.ppath = Some (p,v) \<rparr>"

lemma fp0_rel_ppath_cong[simp]:
  "(s,s')\<in>fp0_rel R \<Longrightarrow> fp0_state_impl.ppath s = fp0_state.ppath s'"
  unfolding restr_simple_state_rel_def fp0_erel_def
  by (cases s, cases s', auto)

lemma fp0_ss_rel_ppath_cong[simp]:
  "(s,s')\<in>\<langle>fp0_erel\<rangle>simple_state_rel \<Longrightarrow> fp0_state_impl.ppath s = fp0_state.ppath s'"
  unfolding simple_state_rel_def fp0_erel_def
  by (cases s, cases s', auto)

lemma fp0i_cong[cong]: "simple_state.more s = simple_state.more s'
  \<Longrightarrow> fp0_state_impl.ppath s = fp0_state_impl.ppath s'"
  by (cases s, cases s', auto)

lemma fp0_erelI: "p=p'
  \<Longrightarrow> (\<lparr> fp0_state_impl.ppath = p \<rparr>, \<lparr> fp0_state.ppath = p'\<rparr>)\<in>fp0_erel"
  unfolding fp0_erel_def by auto

definition fp0_params_impl
  :: "_ \<Rightarrow> ('v,'v fp0_state_impl,('v,unit)fp0_state_impl_ext) gen_parameterization"
where "fp0_params_impl P \<equiv> \<lparr>
  on_init = RETURN no_path_impl,
  on_new_root = \<lambda>v0 s.
    if P v0 then RETURN (a_path_impl [] v0) else RETURN no_path_impl,
  on_discover = \<lambda>u v s.
    if P v then RETURN (a_path_impl (map fst (rev (tl (CAST (ss_stack s))))) v)
    else RETURN no_path_impl,
  on_finish = \<lambda>u s. RETURN (simple_state.more s),
  on_back_edge = \<lambda>u v s. RETURN (simple_state.more s),
  on_cross_edge = \<lambda>u v s. RETURN (simple_state.more s),
  is_break = \<lambda>s. ppath s \<noteq> None \<rparr>"

lemmas fp0_params_impl_simp[simp, DFS_code_unfold]
  = gen_parameterization.simps[mk_record_simp, OF fp0_params_impl_def]

interpretation fp0_impl:
  restricted_impl_defs "fp0_params_impl P" "fp0_params P" G R
  for G P R .

locale fp0_restr = fb_graph
begin
  sublocale fp0?: fp0 "graph_restrict G R"
    apply (rule fp0I)
    apply (rule fb_graph_restrict)
    done

  sublocale impl: restricted_impl G "fp0_params P" "fp0_params_impl P"
    fp0_erel R
    apply unfold_locales
      apply parametricity

      apply (simp add: fp0_erel_def)
      apply (auto) [1]

      apply (auto
        simp: rev_map[symmetric] map_tl comp_def
        simp: fp0_erel_def simple_state_rel_def) [7]

      apply (auto simp: restr_rel_def) [3]
      apply (clarsimp simp: restr_rel_def)
      apply (rule IdD) apply (subst list_rel_id_simp[symmetric])
      apply parametricity
    done
end

definition "find_path0_restr_impl G P R \<equiv> do {
  ASSERT (fb_graph G);
  ASSERT (fp0 (graph_restrict G R));
  s \<leftarrow> fp0_impl.tailrec_impl TYPE('a) G R P;
  case ppath s of
    None \<Rightarrow> RETURN (Inl (visited s))
  | Some (vs,v) \<Rightarrow> RETURN (Inr (vs,v))
}"

lemma find_path0_restr_impl[refine]:
  shows "find_path0_restr_impl G P R
     \<le> \<Down>(\<langle>Id,Id\<times>\<^sub>rId\<rangle>sum_rel)
   (find_path0_restr G P R)"
proof (rule refine_ASSERT_defI2[OF find_path0_restr_def])
  assume "fb_graph G"
  then interpret fb_graph G .
  interpret fp0_restr G by unfold_locales

  show ?thesis
   unfolding find_path0_restr_impl_def find_path0_restr_def
   apply (refine_rcg impl.tailrec_refine)
   apply refine_dref_type
   apply (auto simp: restr_simple_state_rel_def)
   done
qed

definition "find_path0_impl G P \<equiv> do {
  ASSERT (fp0 G);
  s \<leftarrow> fp0_impl.tailrec_impl TYPE('a) G {} P;
  RETURN (ppath s)
}"

lemma find_path0_impl[refine]: "find_path0_impl G P
  \<le> \<Down> (\<langle>Id\<times>\<^sub>rId\<rangle>option_rel) (find_path0 G P)"
proof (rule refine_ASSERT_defI1[OF find_path0_def])
  assume "fp0 G"
  then interpret fp0 G .
  interpret r: fp0_restr G by unfold_locales

  show ?thesis
   unfolding find_path0_impl_def find_path0_def
   apply (refine_rcg r.impl.tailrec_refine[where R="{}", simplified])
   apply (auto)
   done
qed

subsection \<open>Synthesis of Executable Code\<close>
(* Autoref *)

record ('v,'si,'nsi)fp0_state_impl' = "('si,'nsi)simple_state_nos_impl" +
  ppath_impl :: "('v list \<times> 'v) option"

definition [to_relAPP]: "fp0_state_erel erel \<equiv> {
  (\<lparr>ppath_impl = pi, \<dots> =  mi\<rparr>,\<lparr>ppath = p, \<dots> = m\<rparr>) | pi mi p m.
    (pi,p)\<in>\<langle>\<langle>Id\<rangle>list_rel \<times>\<^sub>r Id\<rangle>option_rel \<and> (mi,m)\<in>erel}"

consts
  i_fp0_state_ext :: "interface \<Rightarrow> interface"

lemmas [autoref_rel_intf] = REL_INTFI[of fp0_state_erel i_fp0_state_ext]

term fp0_state_impl_ext
lemma [autoref_rules]:
  fixes ns_rel vis_rel erel
  defines "R \<equiv> \<langle>ns_rel,vis_rel,\<langle>erel\<rangle>fp0_state_erel\<rangle>ssnos_impl_rel"
  shows
    "(fp0_state_impl'_ext, fp0_state_impl_ext)
      \<in> \<langle>\<langle>Id\<rangle>list_rel \<times>\<^sub>r Id\<rangle>option_rel \<rightarrow> erel \<rightarrow> \<langle>erel\<rangle>fp0_state_erel"
    "(ppath_impl, fp0_state_impl.ppath) \<in> R \<rightarrow> \<langle>\<langle>Id\<rangle>list_rel \<times>\<^sub>r Id\<rangle>option_rel"
  unfolding fp0_state_erel_def ssnos_impl_rel_def R_def
  by auto

schematic_goal find_path0_code:
  fixes G :: "('v :: hashable, _) graph_rec_scheme"
  assumes [autoref_rules]:
    "(Gi, G) \<in> \<langle>Rm, Id\<rangle>g_impl_rel_ext"
    "(Pi, P) \<in> Id \<rightarrow> bool_rel"
  notes [autoref_tyrel] = TYRELI[where R="\<langle>Id::('v\<times>'v) set\<rangle>dflt_ahs_rel"]
  shows "(nres_of (?c::?'c dres), find_path0_impl G P) \<in> ?R"
  unfolding find_path0_impl_def[abs_def] DFS_code_unfold ssnos_unfolds
  unfolding if_cancel not_not comp_def nres_monad_laws
  using [[autoref_trace_failed_id]]
  apply (autoref_monadic (trace))
  done

concrete_definition find_path0_code uses find_path0_code
export_code find_path0_code checking SML

lemma find_path0_autoref_aux:
  assumes Vid: "Rv = (Id :: 'a :: hashable rel)"
  shows "(\<lambda>G P. nres_of (find_path0_code G P), find_path0_spec)
    \<in> \<langle>Rm, Rv\<rangle>g_impl_rel_ext \<rightarrow> (Rv \<rightarrow> bool_rel)
      \<rightarrow> \<langle>\<langle>\<langle>Rv\<rangle>list_rel \<times>\<^sub>r Rv\<rangle>option_rel\<rangle>nres_rel"
  apply (intro fun_relI nres_relI)
  unfolding Vid
  apply (rule
    order_trans[OF find_path0_code.refine[param_fo, THEN nres_relD]],
    assumption+
    )
  using find_path0_impl find_path0_correct
  apply (simp add: pw_le_iff refine_pw_simps)
  apply blast
  done
lemmas find_path0_autoref[autoref_rules] = find_path0_autoref_aux[OF PREFER_id_D]

schematic_goal find_path0_restr_code:
  fixes vis_rel :: "('v\<times>'v) set \<Rightarrow> ('visi\<times>'v set) set"
  notes [autoref_rel_intf] = REL_INTFI[of vis_rel "i_set" for I]
  assumes [autoref_rules]: "(op_vis_insert, insert)\<in>Id \<rightarrow> \<langle>Id\<rangle>vis_rel \<rightarrow> \<langle>Id\<rangle>vis_rel"
  assumes [autoref_rules]: "(op_vis_memb, (\<in>))\<in>Id \<rightarrow> \<langle>Id\<rangle>vis_rel \<rightarrow> bool_rel"
  assumes [autoref_rules]:
    "(Gi, G) \<in> \<langle>Rm, Id\<rangle>g_impl_rel_ext"
    "(Pi,P)\<in>Id \<rightarrow> bool_rel"
    "(Ri,R)\<in>\<langle>Id\<rangle>vis_rel"
  shows "(nres_of (?c::?'c dres),
    find_path0_restr_impl
      G
      P
      (R:::\<^sub>r\<langle>Id\<rangle>vis_rel)) \<in> ?R"
  unfolding find_path0_restr_impl_def[abs_def] DFS_code_unfold ssnos_unfolds
  unfolding if_cancel not_not comp_def nres_monad_laws
  using [[autoref_trace_failed_id]]
  apply (autoref_monadic (trace))
  done

concrete_definition find_path0_restr_code uses find_path0_restr_code
export_code find_path0_restr_code checking SML

lemma find_path0_restr_autoref_aux:
  assumes 1: "(op_vis_insert, insert)\<in>Rv \<rightarrow> \<langle>Rv\<rangle>vis_rel \<rightarrow> \<langle>Rv\<rangle>vis_rel"
  assumes 2: "(op_vis_memb, (\<in>))\<in>Rv \<rightarrow> \<langle>Rv\<rangle>vis_rel \<rightarrow> bool_rel"
  assumes Vid: "Rv = Id"
  shows "(\<lambda> G P R. nres_of (find_path0_restr_code op_vis_insert op_vis_memb G P R),
    find_path0_restr_spec)
    \<in> \<langle>Rm, Rv\<rangle>g_impl_rel_ext \<rightarrow> (Rv \<rightarrow> bool_rel) \<rightarrow> \<langle>Rv\<rangle>vis_rel \<rightarrow>
    \<langle>\<langle>\<langle>Rv\<rangle>vis_rel, \<langle>Rv\<rangle>list_rel \<times>\<^sub>r Rv\<rangle>sum_rel\<rangle>nres_rel"
  apply (intro fun_relI nres_relI)
  unfolding Vid
  apply (rule
    order_trans[OF find_path0_restr_code.refine[OF 1[unfolded Vid] 2[unfolded Vid], param_fo, THEN nres_relD]]
    )
  apply assumption+
  using find_path0_restr_impl find_path0_restr_correct
  apply (simp add: pw_le_iff refine_pw_simps)
  apply blast
  done
lemmas find_path0_restr_autoref[autoref_rules] = find_path0_restr_autoref_aux[OF GEN_OP_D GEN_OP_D PREFER_id_D]

schematic_goal find_path1_restr_code:
  fixes vis_rel :: "('v\<times>'v) set \<Rightarrow> ('visi\<times>'v set) set"
  notes [autoref_rel_intf] = REL_INTFI[of vis_rel "i_set" for I]
  assumes [autoref_rules]: "(op_vis_insert, insert)\<in>Id \<rightarrow> \<langle>Id\<rangle>vis_rel \<rightarrow> \<langle>Id\<rangle>vis_rel"
  assumes [autoref_rules]: "(op_vis_memb, (\<in>))\<in>Id \<rightarrow> \<langle>Id\<rangle>vis_rel \<rightarrow> bool_rel"
  assumes [autoref_rules]:
    "(Gi, G) \<in> \<langle>Rm, Id\<rangle>g_impl_rel_ext"
    "(Pi,P)\<in>Id \<rightarrow> bool_rel"
    "(Ri,R)\<in>\<langle>Id\<rangle>vis_rel"
  shows "(nres_of ?c,find_path1_restr G P R)
  \<in> \<langle>\<langle>\<langle>Id\<rangle>vis_rel, \<langle>Id\<rangle>list_rel \<times>\<^sub>r Id\<rangle>sum_rel\<rangle>nres_rel"
  unfolding find_path1_restr_def[abs_def]
  using [[autoref_trace_failed_id]]
  apply (autoref_monadic (trace))
  done

concrete_definition find_path1_restr_code uses find_path1_restr_code
export_code find_path1_restr_code checking SML

lemma find_path1_restr_autoref_aux:
  assumes G: "(op_vis_insert, insert)\<in>V \<rightarrow> \<langle>V\<rangle>vis_rel \<rightarrow> \<langle>V\<rangle>vis_rel"
             "(op_vis_memb, (\<in>))\<in>V \<rightarrow> \<langle>V\<rangle>vis_rel \<rightarrow> bool_rel"
  assumes Vid[simp]: "V=Id"
  shows "(\<lambda> G P R. nres_of (find_path1_restr_code op_vis_insert op_vis_memb G P R),find_path1_restr_spec)
  \<in> \<langle>Rm, V\<rangle>g_impl_rel_ext \<rightarrow> (V \<rightarrow> bool_rel) \<rightarrow> \<langle>V\<rangle>vis_rel \<rightarrow>
    \<langle>\<langle>\<langle>V\<rangle>vis_rel, \<langle>V\<rangle>list_rel \<times>\<^sub>r V\<rangle>sum_rel\<rangle>nres_rel"

proof -
  note find_path1_restr_code.refine[OF G[simplified], param_fo, THEN nres_relD]
  also note find_path1_restr_correct
  finally show ?thesis by (force intro!: nres_relI)
qed

lemmas find_path1_restr_autoref[autoref_rules] = find_path1_restr_autoref_aux[OF GEN_OP_D GEN_OP_D PREFER_id_D]

schematic_goal find_path1_code:
  assumes Vid: "V = (Id :: 'a :: hashable rel)"
  assumes [unfolded Vid,autoref_rules]:
    "(Gi, G) \<in> \<langle>Rm, V\<rangle>g_impl_rel_ext"
    "(Pi,P)\<in>V \<rightarrow> bool_rel"
  notes [autoref_tyrel] = TYRELI[where R="\<langle>(Id::('a\<times>'a::hashable)set)\<rangle>dflt_ahs_rel"]
  shows "(nres_of ?c,find_path1 G P)
  \<in> \<langle>\<langle>\<langle>V\<rangle>list_rel \<times>\<^sub>r V\<rangle>option_rel\<rangle>nres_rel"
  unfolding find_path1_def[abs_def] Vid
  using [[autoref_trace_failed_id]]
  apply (autoref_monadic (trace))
  done
concrete_definition find_path1_code uses find_path1_code

export_code find_path1_code checking SML

lemma find_path1_code_autoref_aux:
  assumes Vid: "V = (Id :: 'a :: hashable rel)"
  shows "(\<lambda> G P. nres_of (find_path1_code G P), find_path1_spec)
    \<in> \<langle>Rm, V\<rangle>g_impl_rel_ext \<rightarrow> (V \<rightarrow> bool_rel) \<rightarrow> \<langle>\<langle>\<langle>V\<rangle>list_rel \<times>\<^sub>r V\<rangle>option_rel\<rangle>nres_rel"
proof -
  note find_path1_code.refine[OF Vid, param_fo, THEN nres_relD, simplified]
  also note find_path1_correct
  finally show ?thesis by (force intro!: nres_relI)
qed

lemmas find_path1_autoref[autoref_rules] = find_path1_code_autoref_aux[OF PREFER_id_D]

subsection \<open>Conclusion\<close>
text \<open>
  We have synthesized an efficient implementation for an algorithm to find a path
  to a reachable node that satisfies a predicate. The algorithm comes in four variants,
  with and without empty path, and with and without node restriction.

  We have set up the Autoref tool, to insert this algorithms for the following
  specifications:
  \<^item> @{term "find_path0_spec G P"} --- find path to node that satisfies @{term P}.
  \<^item> @{term "find_path1_spec G P"} --- find non-empty path to node that satisfies @{term P}.
  \<^item> @{term "find_path0_restr_spec G P R"} --- find path, with nodes from @{term R} already searched.
  \<^item> @{term "find_path1_restr_spec"} --- find non-empty path, with nodes from @{term R} already searched.

\<close>
thm find_path0_autoref
thm find_path1_autoref
thm find_path0_restr_autoref
thm find_path1_restr_autoref

end


theory Rel_LR3_Standard_Compressed
  imports LR3_Standard LR3_Compressed
begin

text \<open>Shows that \<^term>\<open>LR3\<close> (Luby-Rackoff using standard oracle) and \<^term>\<open>LR3c\<close> (Luby-Rackoff using compressed oracle)
      are related by \<^term>\<open>compress\<close>. (Lemma \<open>relation_LR3c_LR3\<close> below.)\<close>

lemma l2: \<open>reg_3_3 compress o\<^sub>C\<^sub>L UP o\<^sub>C\<^sub>L reg_3_3 compress = UPc\<close>
proof -
  have 1: \<open>(reg_1_3 \<circ> Fst;(reg_2_3 \<circ> Fst;reg_3_3)) o reg_3_3 = reg_3_3\<close>
    by (simp add: reg_1_3_def reg_2_3_def reg_3_3_def register_pair_Snd
        flip: comp_assoc)
  have 1: \<open>(reg_1_3 \<circ> Fst;(reg_2_3 \<circ> Fst;reg_3_3)) (reg_3_3 A) = reg_3_3 A\<close>
    for A :: \<open>'z::finite update\<close>
    using 1[THEN fun_cong, of A]
    by (auto simp add: o_def)
  have 2: \<open>B o\<^sub>C\<^sub>L R A o\<^sub>C\<^sub>L (reg_3_3 compress) = B o\<^sub>C\<^sub>L (reg_3_3 compress) o\<^sub>C\<^sub>L R A\<close>
    if [simp]: \<open>compatible reg_3_3 R\<close>
    for A and B :: \<open>(whole \<times> whole \<times> db) update\<close> and R :: \<open>'z::finite update \<Rightarrow> (whole \<times> whole \<times> db) update\<close>
    by (simp add: cblinfun_compose_assoc swap_registers[OF that])
  show ?thesis
    apply (simp add: UP_def UPc_def query_def flip: register_mult cblinfun_compose_assoc 1)
    by (simp add: 1 2 2[of _ id_cblinfun, simplified])
qed

lemma l1: \<open>D1 compress o\<^sub>C\<^sub>L (X;(X1;D1)) UP o\<^sub>C\<^sub>L D1 compress = (X;(X1;D1)) UPc\<close>
  if [register]: \<open>mutually compatible (X,X1,D1)\<close>
  for D1 X X1
proof -
  have 1: \<open>D1 = (X;(X1;D1)) o reg_3_3\<close>
    by (simp add: reg_3_3_def register_pair_Snd flip: comp_assoc)
  have \<open>D1 compress o\<^sub>C\<^sub>L (X;(X1;D1)) UP o\<^sub>C\<^sub>L D1 compress =
      (X;(X1;D1)) (reg_3_3 compress o\<^sub>C\<^sub>L UP o\<^sub>C\<^sub>L reg_3_3 compress)\<close>
    by (simp add: 1[unfolded o_def, THEN fun_cong] register_mult)
  also have \<open>\<dots> = (X;(X1;D1)) UPc\<close>
    by (simp add: l2)
  finally show ?thesis
    by -
qed

lemma relation_LR3c_LR3: \<open>LR3c = D1 compress o\<^sub>C\<^sub>L D2 compress o\<^sub>C\<^sub>L D3 compress o\<^sub>C\<^sub>L LR3 o\<^sub>C\<^sub>L D3 compress o\<^sub>C\<^sub>L D2 compress o\<^sub>C\<^sub>L D1 compress\<close>
proof -
  have rm_end[intro!]: \<open>A o\<^sub>C\<^sub>L B = A o\<^sub>C\<^sub>L B'\<close> if \<open>B = B'\<close> for A A' B B' :: \<open>('z ell2, 'z ell2) cblinfun\<close>
    using that by simp
  have rm_start[intro!]: \<open>A o\<^sub>C\<^sub>L B = A' o\<^sub>C\<^sub>L B\<close> if \<open>A = A'\<close> for A A' B B' :: \<open>('z ell2, 'z ell2) cblinfun\<close>
    using that by simp
  have vanish[simp]:
    \<open>A o\<^sub>C\<^sub>L D1 compress o\<^sub>C\<^sub>L D1 compress = A\<close>
    \<open>A o\<^sub>C\<^sub>L D2 compress o\<^sub>C\<^sub>L D2 compress = A\<close>
    for A :: \<open>state ell2 \<Rightarrow>\<^sub>C\<^sub>L state ell2\<close>
    by (auto simp: cblinfun_compose_assoc register_mult compress_square intro: swap_registers)
  have D1_front:
    \<open>A o\<^sub>C\<^sub>L D2 compress o\<^sub>C\<^sub>L D1 compress = A o\<^sub>C\<^sub>L D1 compress o\<^sub>C\<^sub>L D2 compress\<close>
    \<open>A o\<^sub>C\<^sub>L D3 compress o\<^sub>C\<^sub>L D1 compress = A o\<^sub>C\<^sub>L D1 compress o\<^sub>C\<^sub>L D3 compress\<close>
    \<open>A o\<^sub>C\<^sub>L (X1;(X2;D2)) UP o\<^sub>C\<^sub>L D1 compress = A o\<^sub>C\<^sub>L D1 compress o\<^sub>C\<^sub>L (X1;(X2;D2)) UP\<close>
    \<open>A o\<^sub>C\<^sub>L (X2;(Y;D3)) UP o\<^sub>C\<^sub>L D1 compress = A o\<^sub>C\<^sub>L D1 compress o\<^sub>C\<^sub>L (X2;(Y;D3)) UP\<close>
    for A :: \<open>state ell2 \<Rightarrow>\<^sub>C\<^sub>L state ell2\<close>
    by (auto simp: cblinfun_compose_assoc intro: swap_registers)
  have D2_front:
    \<open>A o\<^sub>C\<^sub>L D3 compress o\<^sub>C\<^sub>L D2 compress = A o\<^sub>C\<^sub>L D2 compress o\<^sub>C\<^sub>L D3 compress\<close>
    \<open>A o\<^sub>C\<^sub>L (X;(X1;D1)) UP o\<^sub>C\<^sub>L D2 compress = A o\<^sub>C\<^sub>L D2 compress o\<^sub>C\<^sub>L (X;(X1;D1)) UP\<close>
    \<open>A o\<^sub>C\<^sub>L (X2;(Y;D3)) UP o\<^sub>C\<^sub>L D2 compress = A o\<^sub>C\<^sub>L D2 compress o\<^sub>C\<^sub>L (X2;(Y;D3)) UP\<close>
    for A :: \<open>state ell2 \<Rightarrow>\<^sub>C\<^sub>L state ell2\<close>
    by (auto simp: cblinfun_compose_assoc intro: swap_registers)
  have D3_front:
    \<open>A o\<^sub>C\<^sub>L D2 compress o\<^sub>C\<^sub>L D3 compress = A o\<^sub>C\<^sub>L D3 compress o\<^sub>C\<^sub>L D2 compress\<close>
    \<open>A o\<^sub>C\<^sub>L (X;(X1;D1)) UP o\<^sub>C\<^sub>L D3 compress = A o\<^sub>C\<^sub>L D3 compress o\<^sub>C\<^sub>L (X;(X1;D1)) UP\<close>
    \<open>A o\<^sub>C\<^sub>L (X1;(X2;D2)) UP o\<^sub>C\<^sub>L D3 compress = A o\<^sub>C\<^sub>L D3 compress o\<^sub>C\<^sub>L (X1;(X2;D2)) UP\<close>
    for A :: \<open>state ell2 \<Rightarrow>\<^sub>C\<^sub>L state ell2\<close>
    by (auto simp: cblinfun_compose_assoc intro: swap_registers)

  have \<open>D1 compress o\<^sub>C\<^sub>L D2 compress o\<^sub>C\<^sub>L D3 compress o\<^sub>C\<^sub>L LR3 o\<^sub>C\<^sub>L D3 compress o\<^sub>C\<^sub>L D2 compress o\<^sub>C\<^sub>L D1 compress
    = (D1 compress o\<^sub>C\<^sub>L (X;(X1;D1)) UP o\<^sub>C\<^sub>L D1 compress)
   o\<^sub>C\<^sub>L (D2 compress o\<^sub>C\<^sub>L (X1;(X2;D2)) UP o\<^sub>C\<^sub>L D2 compress)
   o\<^sub>C\<^sub>L (D3 compress o\<^sub>C\<^sub>L (X2;(Y;D3)) UP o\<^sub>C\<^sub>L D3 compress)
   o\<^sub>C\<^sub>L (D2 compress o\<^sub>C\<^sub>L (X1;(X2;D2)) UP o\<^sub>C\<^sub>L D2 compress)
   o\<^sub>C\<^sub>L (D1 compress o\<^sub>C\<^sub>L (X;(X1;D1)) UP o\<^sub>C\<^sub>L D1 compress)\<close>
    apply (auto simp add: LR3_def simp flip: cblinfun_compose_assoc) (* remove D1 at end *)
    apply (auto simp add: cblinfun_compose_assoc) (* remove D1 at start *)
    apply (auto simp add: D2_front simp flip: cblinfun_compose_assoc)
    apply (auto simp add: D3_front simp flip: cblinfun_compose_assoc) (* remove (X;(X1;D1)) at end *)
    apply (auto simp add: D1_front simp flip: cblinfun_compose_assoc) (* remove D2 at end *)
    apply (auto simp add: D2_front D2_front[of id_cblinfun, simplified] simp flip: cblinfun_compose_assoc) (* remove D2 at end *)
    by (auto simp add: D3_front simp flip: cblinfun_compose_assoc) (* remove (X1;(X2;D2)) at end *)

  also have \<open>\<dots> = LR3c\<close>
    by (simp add: LR3c_def l1)

  finally show ?thesis
    by simp
qed

end