section \<open>Standard HOL Bindings\<close>
theory Autoref_Bindings_HOL
imports "Tool/Autoref_Tool"
begin

  subsection "Structural Expansion"
  text \<open>
    In some situations, autoref imitates the operations on typeclasses and
    the typeclass hierarchy. This may result in structural mismatches, e.g.,
    a hashcode side-condition may look like:
      @{text [display] "is_hashcode (prod_eq (=) (=)) hashcode"}

    This cannot be discharged by the rule
      @{text [display] "is_hashcode (=) hashcode"}

    In order to handle such cases, we introduce a set of simplification lemmas
    that expand the structure of an operator as far as possible.
    These lemmas are integrated into a tagged solver, that can prove equality
    between operators modulo structural expansion.
\<close>

definition [simp]: "STRUCT_EQ_tag x y \<equiv> x = y"
lemma STRUCT_EQ_tagI: "x=y \<Longrightarrow> STRUCT_EQ_tag x y" by simp

ML \<open>
  structure Autoref_Struct_Expand = struct
    structure autoref_struct_expand = Named_Thms (
      val name = @{binding autoref_struct_expand}
      val description = "Autoref: Structural expansion lemmas"
    )

    fun expand_tac ctxt = let
      val ss = put_simpset HOL_basic_ss ctxt addsimps autoref_struct_expand.get ctxt
    in
      SOLVED' (asm_simp_tac ss)
    end

    val setup = autoref_struct_expand.setup
    val decl_setup = fn phi =>
      Tagged_Solver.declare_solver @{thms STRUCT_EQ_tagI} @{binding STRUCT_EQ}
        "Autoref: Equality modulo structural expansion"
        (expand_tac) phi

  end
\<close>

setup Autoref_Struct_Expand.setup
declaration Autoref_Struct_Expand.decl_setup

text \<open>Sometimes, also relators must be expanded. Usually to check them to be the identity relator\<close>
definition [simp]: "REL_IS_ID R \<equiv> R=Id"
definition [simp]: "REL_FORCE_ID R \<equiv> R=Id"
lemma REL_IS_ID_trigger: "R=Id \<Longrightarrow> REL_IS_ID R" by simp
lemma REL_FORCE_ID_trigger: "R=Id \<Longrightarrow> REL_FORCE_ID R" by simp

declaration \<open>Tagged_Solver.add_triggers
  "Relators.relator_props_solver" @{thms REL_IS_ID_trigger}\<close>

declaration \<open>Tagged_Solver.add_triggers
  "Relators.force_relator_props_solver" @{thms REL_FORCE_ID_trigger}\<close>

abbreviation "PREFER_id R \<equiv> PREFER REL_IS_ID R"

  (* TODO: Most of these are parametricity theorems! *)

  lemmas [autoref_rel_intf] = REL_INTFI[of fun_rel i_fun]

  subsection "Booleans"
  consts
    i_bool :: interface

  lemmas [autoref_rel_intf] = REL_INTFI[of bool_rel i_bool]

  lemma [autoref_itype]:
    "True ::\<^sub>i i_bool"
    "False ::\<^sub>i i_bool"
    "conj ::\<^sub>i i_bool \<rightarrow>\<^sub>i i_bool \<rightarrow>\<^sub>i i_bool"
    "(\<longleftrightarrow>) ::\<^sub>i i_bool \<rightarrow>\<^sub>i i_bool \<rightarrow>\<^sub>i i_bool"
    "(\<longrightarrow>) ::\<^sub>i i_bool \<rightarrow>\<^sub>i i_bool \<rightarrow>\<^sub>i i_bool"
    "disj ::\<^sub>i i_bool \<rightarrow>\<^sub>i i_bool \<rightarrow>\<^sub>i i_bool"
    "Not ::\<^sub>i i_bool \<rightarrow>\<^sub>i i_bool"
    "case_bool ::\<^sub>i I \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i i_bool \<rightarrow>\<^sub>i I"
    "old.rec_bool ::\<^sub>i I \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i i_bool \<rightarrow>\<^sub>i I"
    by auto

  lemma autoref_bool[autoref_rules]:
    "(x,x)\<in>bool_rel"
    "(conj,conj)\<in>bool_rel\<rightarrow>bool_rel\<rightarrow>bool_rel"
    "(disj,disj)\<in>bool_rel\<rightarrow>bool_rel\<rightarrow>bool_rel"
    "(Not,Not)\<in>bool_rel\<rightarrow>bool_rel"
    "(case_bool,case_bool)\<in>R\<rightarrow>R\<rightarrow>bool_rel\<rightarrow>R"
    "(old.rec_bool,old.rec_bool)\<in>R\<rightarrow>R\<rightarrow>bool_rel\<rightarrow>R"
    "((\<longleftrightarrow>), (\<longleftrightarrow>))\<in>bool_rel\<rightarrow>bool_rel\<rightarrow>bool_rel"
    "((\<longrightarrow>), (\<longrightarrow>))\<in>bool_rel\<rightarrow>bool_rel\<rightarrow>bool_rel"
    by (auto split: bool.split simp: rec_bool_is_case)

  subsection "Standard Type Classes"

context begin interpretation autoref_syn .
  text \<open>
    We allow these operators for all interfaces.
\<close>
  lemma [autoref_itype]:
    "(<) ::\<^sub>i I \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i i_bool"
    "(\<le>) ::\<^sub>i I \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i i_bool"
    "(=) ::\<^sub>i I \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i i_bool"
    "(+) ::\<^sub>i I \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i I"
    "(-) ::\<^sub>i I \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i I"
    "(div) ::\<^sub>i I \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i I"
    "(mod) ::\<^sub>i I \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i I"
    "(*) ::\<^sub>i I \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i I"
    "0 ::\<^sub>i I"
    "1 ::\<^sub>i I"
    "numeral x ::\<^sub>i I"
    "uminus ::\<^sub>i I \<rightarrow>\<^sub>i I"
    by auto

  lemma pat_num_generic[autoref_op_pat]:
    "0 \<equiv> OP 0 :::\<^sub>i I"
    "1 \<equiv> OP 1 :::\<^sub>i I"
    "numeral x \<equiv> (OP (numeral x) :::\<^sub>i I)"
    by simp_all

  lemma [autoref_rules]:
    assumes "PRIO_TAG_GEN_ALGO"
    shows "((<), (<)) \<in> Id\<rightarrow>Id\<rightarrow>bool_rel"
    and "((\<le>), (\<le>)) \<in> Id\<rightarrow>Id\<rightarrow>bool_rel"
    and "((=), (=)) \<in> Id\<rightarrow>Id\<rightarrow>bool_rel"
    and "(numeral x,OP (numeral x) ::: Id) \<in> Id"
    and "(uminus,uminus) \<in> Id \<rightarrow> Id"
    and "(0,0) \<in> Id"
    and "(1,1) \<in> Id"
    by auto

  subsection "Functional Combinators"
  lemma [autoref_itype]: "id ::\<^sub>i I \<rightarrow>\<^sub>i I" by simp
  lemma autoref_id[autoref_rules]: "(id,id)\<in>R\<rightarrow>R" by auto

  term "(o)"
  lemma [autoref_itype]: "(\<circ>) ::\<^sub>i (Ia\<rightarrow>\<^sub>iIb) \<rightarrow>\<^sub>i (Ic \<rightarrow>\<^sub>i Ia) \<rightarrow>\<^sub>i Ic \<rightarrow>\<^sub>i Ib"
    by simp
  lemma autoref_comp[autoref_rules]:
    "((o), (o)) \<in> (Ra \<rightarrow> Rb) \<rightarrow> (Rc \<rightarrow> Ra) \<rightarrow> Rc \<rightarrow> Rb"
    by (auto dest: fun_relD)

  lemma [autoref_itype]: "If ::\<^sub>i i_bool \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i I" by simp
  lemma autoref_If[autoref_rules]: "(If,If)\<in>Id\<rightarrow>R\<rightarrow>R\<rightarrow>R" by auto
  lemma autoref_If_cong[autoref_rules]:
    assumes "(c',c)\<in>Id"
    assumes "REMOVE_INTERNAL c \<Longrightarrow> (t',t)\<in>R"
    assumes "\<not> REMOVE_INTERNAL c \<Longrightarrow> (e',e)\<in>R"
    shows "(If c' t' e',(OP If ::: Id\<rightarrow>R\<rightarrow>R\<rightarrow>R)$c$t$e)\<in>R"
    using assms by (auto)

  lemma [autoref_itype]: "Let ::\<^sub>i Ix \<rightarrow>\<^sub>i (Ix\<rightarrow>\<^sub>iIy) \<rightarrow>\<^sub>i Iy" by auto
  lemma autoref_Let:
    "(Let,Let)\<in>Ra \<rightarrow> (Ra\<rightarrow>Rr) \<rightarrow> Rr"
    by (auto dest: fun_relD)

  lemma autoref_Let_cong[autoref_rules]:
    assumes "(x',x)\<in>Ra"
    assumes "\<And>y y'. REMOVE_INTERNAL (x=y) \<Longrightarrow> (y',y)\<in>Ra \<Longrightarrow> (f' y', f$y)\<in>Rr"
    shows "(Let x' f',(OP Let ::: Ra \<rightarrow> (Ra \<rightarrow> Rr) \<rightarrow> Rr)$x$f)\<in>Rr"
    using assms by (auto)

end

  subsection "Unit"
  consts i_unit :: interface
  lemmas [autoref_rel_intf] = REL_INTFI[of unit_rel i_unit]

  (*lemma [autoref_itype]: "(a::unit) ::\<^sub>i i_unit" by simp*)
  lemma [autoref_rules]: "((),())\<in>unit_rel" by simp

  subsection "Nat"
    consts i_nat :: interface
    lemmas [autoref_rel_intf] = REL_INTFI[of nat_rel i_nat]

context begin interpretation autoref_syn .
    lemma pat_num_nat[autoref_op_pat]:
      "0::nat \<equiv> OP 0 :::\<^sub>i i_nat"
      "1::nat \<equiv> OP 1 :::\<^sub>i i_nat"
      "(numeral x)::nat \<equiv> (OP (numeral x) :::\<^sub>i i_nat)"
      by simp_all

    lemma autoref_nat[autoref_rules]:
      "(0, 0::nat) \<in> nat_rel"
      "(Suc, Suc) \<in> nat_rel \<rightarrow> nat_rel"
      "(1, 1::nat) \<in> nat_rel"
      "(numeral n::nat,numeral n::nat) \<in> nat_rel"
      "((<), (<) ::nat \<Rightarrow> _) \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> bool_rel"
      "((\<le>), (\<le>) ::nat \<Rightarrow> _) \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> bool_rel"
      "((=), (=) ::nat \<Rightarrow> _) \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> bool_rel"
      "((+) ::nat\<Rightarrow>_,(+))\<in>nat_rel\<rightarrow>nat_rel\<rightarrow>nat_rel"
      "((-) ::nat\<Rightarrow>_,(-))\<in>nat_rel\<rightarrow>nat_rel\<rightarrow>nat_rel"
      "((div) ::nat\<Rightarrow>_,(div))\<in>nat_rel\<rightarrow>nat_rel\<rightarrow>nat_rel"
      "((*), (*))\<in>nat_rel\<rightarrow>nat_rel\<rightarrow>nat_rel"
      "((mod), (mod))\<in>nat_rel\<rightarrow>nat_rel\<rightarrow>nat_rel"
      by auto

    lemma autoref_case_nat[autoref_rules]:
      "(case_nat,case_nat)\<in>Ra \<rightarrow> (Id \<rightarrow> Ra) \<rightarrow> Id \<rightarrow> Ra"
      apply (intro fun_relI)
      apply (auto split: nat.split dest: fun_relD)
      done

    lemma autoref_rec_nat: "(rec_nat,rec_nat) \<in> R \<rightarrow> (Id \<rightarrow> R \<rightarrow> R) \<rightarrow> Id \<rightarrow> R"
      apply (intro fun_relI)
    proof goal_cases
      case (1 s s' f f' n n') thus ?case
        apply (induct n' arbitrary: n s s')
        apply (fastforce simp: fun_rel_def)+
        done
    qed
end

  subsection "Int"
    consts i_int :: interface
    lemmas [autoref_rel_intf] = REL_INTFI[of int_rel i_int]

context begin interpretation autoref_syn .
    lemma pat_num_int[autoref_op_pat]:
      "0::int \<equiv> OP 0 :::\<^sub>i i_int"
      "1::int \<equiv> OP 1 :::\<^sub>i i_int"
      "(numeral x)::int \<equiv> (OP (numeral x) :::\<^sub>i i_int)"
      by simp_all

    (*lemma [autoref_itype]:
      "((<) :: int \<Rightarrow> _) ::\<^sub>i i_int \<rightarrow>\<^sub>i i_int \<rightarrow>\<^sub>i i_bool"
      "((\<le>) :: int \<Rightarrow> _) ::\<^sub>i i_int \<rightarrow>\<^sub>i i_int \<rightarrow>\<^sub>i i_bool"
      "((=) :: int \<Rightarrow> _) ::\<^sub>i i_int \<rightarrow>\<^sub>i i_int \<rightarrow>\<^sub>i i_bool"
      "((+) :: int \<Rightarrow> _) ::\<^sub>i i_int \<rightarrow>\<^sub>i i_int \<rightarrow>\<^sub>i i_int"
      "((-) :: int \<Rightarrow> _) ::\<^sub>i i_int \<rightarrow>\<^sub>i i_int \<rightarrow>\<^sub>i i_int"
      "((div) :: int \<Rightarrow> _) ::\<^sub>i i_int \<rightarrow>\<^sub>i i_int \<rightarrow>\<^sub>i i_int"
      "(uminus :: int \<Rightarrow> _) ::\<^sub>i i_int \<rightarrow>\<^sub>i i_int"
      by auto*)

    lemma autoref_int[autoref_rules (overloaded)]:
      "(0, 0::int) \<in> int_rel"
      "(1, 1::int) \<in> int_rel"
      "(numeral n::int,numeral n::int) \<in> int_rel"
      "((<), (<) ::int \<Rightarrow> _) \<in> int_rel \<rightarrow> int_rel \<rightarrow> bool_rel"
      "((\<le>), (\<le>) ::int \<Rightarrow> _) \<in> int_rel \<rightarrow> int_rel \<rightarrow> bool_rel"
      "((=), (=) ::int \<Rightarrow> _) \<in> int_rel \<rightarrow> int_rel \<rightarrow> bool_rel"
      "((+) ::int\<Rightarrow>_,(+))\<in>int_rel\<rightarrow>int_rel\<rightarrow>int_rel"
      "((-) ::int\<Rightarrow>_,(-))\<in>int_rel\<rightarrow>int_rel\<rightarrow>int_rel"
      "((div) ::int\<Rightarrow>_,(div))\<in>int_rel\<rightarrow>int_rel\<rightarrow>int_rel"
      "(uminus,uminus)\<in>int_rel\<rightarrow>int_rel"
      "((*), (*))\<in>int_rel\<rightarrow>int_rel\<rightarrow>int_rel"
      "((mod), (mod))\<in>int_rel\<rightarrow>int_rel\<rightarrow>int_rel"
      by auto
end

  subsection "Product"
    consts i_prod :: "interface \<Rightarrow> interface \<Rightarrow> interface"
    lemmas [autoref_rel_intf] = REL_INTFI[of prod_rel i_prod]

context begin interpretation autoref_syn .
    (*
    lemma [autoref_itype]:
      "Pair ::\<^sub>i Ia \<rightarrow>\<^sub>i Ib \<rightarrow>\<^sub>i \<langle>Ia,Ib\<rangle>\<^sub>ii_prod"
      "case_prod ::\<^sub>i (Ia \<rightarrow>\<^sub>i Ib \<rightarrow>\<^sub>i I) \<rightarrow>\<^sub>i \<langle>Ia,Ib\<rangle>\<^sub>ii_prod \<rightarrow>\<^sub>i I"
      "old.rec_prod ::\<^sub>i (Ia \<rightarrow>\<^sub>i Ib \<rightarrow>\<^sub>i I) \<rightarrow>\<^sub>i \<langle>Ia,Ib\<rangle>\<^sub>ii_prod \<rightarrow>\<^sub>i I"
      "fst ::\<^sub>i \<langle>Ia,Ib\<rangle>\<^sub>ii_prod \<rightarrow>\<^sub>i Ia"
      "snd ::\<^sub>i \<langle>Ia,Ib\<rangle>\<^sub>ii_prod \<rightarrow>\<^sub>i Ib"
      "((=) :: _\<times>_ \<Rightarrow> _) ::\<^sub>i \<langle>Ia,Ib\<rangle>\<^sub>ii_prod \<rightarrow>\<^sub>i \<langle>Ia,Ib\<rangle>\<^sub>ii_prod \<rightarrow>\<^sub>i i_bool"
      by auto
      *)

    lemma prod_refine[autoref_rules]:
      "(Pair,Pair)\<in>Ra \<rightarrow> Rb \<rightarrow> \<langle>Ra,Rb\<rangle>prod_rel"
      "(case_prod,case_prod) \<in> (Ra \<rightarrow> Rb \<rightarrow> Rr) \<rightarrow> \<langle>Ra,Rb\<rangle>prod_rel \<rightarrow> Rr"
      "(old.rec_prod,old.rec_prod) \<in> (Ra \<rightarrow> Rb \<rightarrow> Rr) \<rightarrow> \<langle>Ra,Rb\<rangle>prod_rel \<rightarrow> Rr"
      "(fst,fst)\<in>\<langle>Ra,Rb\<rangle>prod_rel \<rightarrow> Ra"
      "(snd,snd)\<in>\<langle>Ra,Rb\<rangle>prod_rel \<rightarrow> Rb"
      by (auto dest: fun_relD split: prod.split
        simp: prod_rel_def rec_prod_is_case)

    definition "prod_eq eqa eqb x1 x2 \<equiv>
      case x1 of (a1,b1) \<Rightarrow> case x2 of (a2,b2) \<Rightarrow> eqa a1 a2 \<and> eqb b1 b2"

    lemma prod_eq_autoref[autoref_rules (overloaded)]:
      "\<lbrakk>GEN_OP eqa (=) (Ra\<rightarrow>Ra\<rightarrow>Id); GEN_OP eqb (=) (Rb\<rightarrow>Rb\<rightarrow>Id)\<rbrakk>
      \<Longrightarrow> (prod_eq eqa eqb,(=)) \<in> \<langle>Ra,Rb\<rangle>prod_rel \<rightarrow> \<langle>Ra,Rb\<rangle>prod_rel \<rightarrow> Id"
      unfolding prod_eq_def[abs_def]
      by (fastforce dest: fun_relD)

    lemma prod_eq_expand[autoref_struct_expand]: "(=) = prod_eq (=) (=)"
      unfolding prod_eq_def[abs_def]
      by (auto intro!: ext)
end

  subsection "Option"
    consts i_option :: "interface \<Rightarrow> interface"
    lemmas [autoref_rel_intf] = REL_INTFI[of option_rel i_option]

context begin interpretation autoref_syn .
    (*
    lemma [autoref_itype]:
      "None ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_option"
      "Some ::\<^sub>i I \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_option"
      "the ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_option \<rightarrow>\<^sub>i I"
      "case_option ::\<^sub>i I \<rightarrow>\<^sub>i (Iv\<rightarrow>\<^sub>iI) \<rightarrow>\<^sub>i \<langle>Iv\<rangle>\<^sub>ii_option \<rightarrow>\<^sub>i I"
      "rec_option ::\<^sub>i I \<rightarrow>\<^sub>i (Iv\<rightarrow>\<^sub>iI) \<rightarrow>\<^sub>i \<langle>Iv\<rangle>\<^sub>ii_option \<rightarrow>\<^sub>i I"
      "((=) :: _ option \<Rightarrow> _) ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_option \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_option \<rightarrow>\<^sub>i i_bool"
      by auto
      *)

    lemma autoref_opt[autoref_rules]:
      "(None,None)\<in>\<langle>R\<rangle>option_rel"
      "(Some,Some)\<in>R \<rightarrow> \<langle>R\<rangle>option_rel"
      "(case_option,case_option)\<in>Rr\<rightarrow>(R \<rightarrow> Rr)\<rightarrow>\<langle>R\<rangle>option_rel \<rightarrow> Rr"
      "(rec_option,rec_option)\<in>Rr\<rightarrow>(R \<rightarrow> Rr)\<rightarrow>\<langle>R\<rangle>option_rel \<rightarrow> Rr"
      by (auto split: option.split
        simp: option_rel_def case_option_def[symmetric]
        dest: fun_relD)

    lemma autoref_the[autoref_rules]:
      assumes "SIDE_PRECOND (x\<noteq>None)"
      assumes "(x',x)\<in>\<langle>R\<rangle>option_rel"
      shows "(the x', (OP the ::: \<langle>R\<rangle>option_rel \<rightarrow> R)$x) \<in> R"
      using assms
      by (auto simp: option_rel_def)

    lemma autoref_the_default[autoref_rules]:
      "(the_default, the_default) \<in> R \<rightarrow> \<langle>R\<rangle>option_rel \<rightarrow> R"
      by parametricity

    definition [simp]: "is_None a \<equiv> case a of None \<Rightarrow> True | _ \<Rightarrow> False"
    lemma pat_isNone[autoref_op_pat]:
      "a=None \<equiv> (OP is_None :::\<^sub>i \<langle>I\<rangle>\<^sub>ii_option \<rightarrow>\<^sub>i i_bool)$a"
      "None=a \<equiv> (OP is_None :::\<^sub>i \<langle>I\<rangle>\<^sub>ii_option \<rightarrow>\<^sub>i i_bool)$a"
      by (auto intro!: eq_reflection split: option.splits)
    lemma autoref_is_None[param,autoref_rules]:
      "(is_None,is_None)\<in>\<langle>R\<rangle>option_rel \<rightarrow> Id"
      by (auto split: option.splits)

    lemma fold_is_None: "x=None \<longleftrightarrow> is_None x" by (cases x) auto

    definition "option_eq eq v1 v2 \<equiv>
      case (v1,v2) of
        (None,None) \<Rightarrow> True
      | (Some x1, Some x2) \<Rightarrow> eq x1 x2
      | _ \<Rightarrow> False"

    lemma option_eq_autoref[autoref_rules (overloaded)]:
      "\<lbrakk>GEN_OP eq (=) (R\<rightarrow>R\<rightarrow>Id)\<rbrakk>
      \<Longrightarrow> (option_eq eq,(=)) \<in> \<langle>R\<rangle>option_rel \<rightarrow> \<langle>R\<rangle>option_rel \<rightarrow> Id"
      unfolding option_eq_def[abs_def]
      by (auto dest: fun_relD split: option.splits elim!: option_relE)

    lemma option_eq_expand[autoref_struct_expand]:
      "(=) = option_eq (=)"
      by (auto intro!: ext simp: option_eq_def split: option.splits)
end

  subsection "Sum-Types"
  consts i_sum :: "interface \<Rightarrow> interface \<Rightarrow> interface"
  lemmas [autoref_rel_intf] = REL_INTFI[of sum_rel i_sum]

context begin interpretation autoref_syn .
  (*lemma [autoref_itype]:
    "((=) :: _+_ \<Rightarrow> _) ::\<^sub>i \<langle>Il,Ir\<rangle>\<^sub>ii_sum \<rightarrow>\<^sub>i \<langle>Il,Ir\<rangle>\<^sub>ii_sum \<rightarrow>\<^sub>i i_bool"
    "Inl ::\<^sub>i Il \<rightarrow>\<^sub>i \<langle>Il,Ir\<rangle>\<^sub>ii_sum"
    "Inr ::\<^sub>i Ir \<rightarrow>\<^sub>i \<langle>Il,Ir\<rangle>\<^sub>ii_sum"
    "case_sum ::\<^sub>i (Il\<rightarrow>\<^sub>iI) \<rightarrow>\<^sub>i (Ir \<rightarrow>\<^sub>i I) \<rightarrow>\<^sub>i \<langle>Il,Ir\<rangle>\<^sub>ii_sum \<rightarrow>\<^sub>i I"
    "old.rec_sum ::\<^sub>i (Il\<rightarrow>\<^sub>iI) \<rightarrow>\<^sub>i (Ir \<rightarrow>\<^sub>i I) \<rightarrow>\<^sub>i \<langle>Il,Ir\<rangle>\<^sub>ii_sum \<rightarrow>\<^sub>i I"
    by auto*)

  lemma autoref_sum[autoref_rules]:
    "(Inl,Inl) \<in> Rl \<rightarrow> \<langle>Rl,Rr\<rangle>sum_rel"
    "(Inr,Inr) \<in> Rr \<rightarrow> \<langle>Rl,Rr\<rangle>sum_rel"
    "(case_sum,case_sum) \<in> (Rl \<rightarrow> R) \<rightarrow> (Rr \<rightarrow> R) \<rightarrow> \<langle>Rl,Rr\<rangle>sum_rel \<rightarrow> R"
    "(old.rec_sum,old.rec_sum) \<in> (Rl \<rightarrow> R) \<rightarrow> (Rr \<rightarrow> R) \<rightarrow> \<langle>Rl,Rr\<rangle>sum_rel \<rightarrow> R"
    by (fastforce split: sum.split dest: fun_relD
      simp: rec_sum_is_case)+

  definition "sum_eq eql eqr s1 s2 \<equiv>
    case (s1,s2) of
      (Inl x1, Inl x2) \<Rightarrow> eql x1 x2
    | (Inr x1, Inr x2) \<Rightarrow> eqr x1 x2
    | _ \<Rightarrow> False"

  lemma sum_eq_autoref[autoref_rules (overloaded)]:
    "\<lbrakk>GEN_OP eql (=) (Rl\<rightarrow>Rl\<rightarrow>Id); GEN_OP eqr (=) (Rr\<rightarrow>Rr\<rightarrow>Id)\<rbrakk>
    \<Longrightarrow> (sum_eq eql eqr,(=)) \<in> \<langle>Rl,Rr\<rangle>sum_rel \<rightarrow> \<langle>Rl,Rr\<rangle>sum_rel \<rightarrow> Id"
    unfolding sum_eq_def[abs_def]
    by (fastforce dest: fun_relD elim!: sum_relE)

  lemma sum_eq_expand[autoref_struct_expand]: "(=) = sum_eq (=) (=)"
    by (auto intro!: ext simp: sum_eq_def split: sum.splits)

  lemmas [autoref_rules] = is_Inl_param is_Inr_param

  lemma autoref_sum_Projl[autoref_rules]:
    "\<lbrakk>SIDE_PRECOND (is_Inl s); (s',s)\<in>\<langle>Ra,Rb\<rangle>sum_rel\<rbrakk>
    \<Longrightarrow> (Sum_Type.sum.projl s', (OP Sum_Type.sum.projl ::: \<langle>Ra,Rb\<rangle>sum_rel \<rightarrow> Ra)$s)\<in>Ra"
    by simp parametricity

  lemma autoref_sum_Projr[autoref_rules]:
    "\<lbrakk>SIDE_PRECOND (is_Inr s); (s',s)\<in>\<langle>Ra,Rb\<rangle>sum_rel\<rbrakk>
    \<Longrightarrow> (Sum_Type.sum.projr s', (OP Sum_Type.sum.projr ::: \<langle>Ra,Rb\<rangle>sum_rel \<rightarrow> Rb)$s)\<in>Rb"
    by simp parametricity

end

subsection "List"
  consts i_list :: "interface \<Rightarrow> interface"
  lemmas [autoref_rel_intf] = REL_INTFI[of list_rel i_list]

context begin interpretation autoref_syn .
  (*
  term nth
  lemma [autoref_itype]:
    "((=) :: _ list \<Rightarrow> _) ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i i_bool"
    "[] ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_list"
    "(#) ::\<^sub>i I \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_list"
    "(@) ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_list"
    "case_list ::\<^sub>i Ir \<rightarrow>\<^sub>i (I\<rightarrow>\<^sub>i\<langle>I\<rangle>\<^sub>ii_list\<rightarrow>\<^sub>iIr) \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i Ir"
    "rec_list ::\<^sub>i Ir \<rightarrow>\<^sub>i (I\<rightarrow>\<^sub>i\<langle>I\<rangle>\<^sub>ii_list\<rightarrow>\<^sub>iIr\<rightarrow>\<^sub>iIr) \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i Ir"
    "map ::\<^sub>i (I1\<rightarrow>\<^sub>iI2) \<rightarrow>\<^sub>i \<langle>I1\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i \<langle>I2\<rangle>\<^sub>ii_list"
    "foldl ::\<^sub>i (Ia\<rightarrow>\<^sub>iIb\<rightarrow>\<^sub>iIa) \<rightarrow>\<^sub>i Ia \<rightarrow>\<^sub>i \<langle>Ib\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i Ia"
    "foldr ::\<^sub>i (Ia\<rightarrow>\<^sub>iIb\<rightarrow>\<^sub>iIb) \<rightarrow>\<^sub>i \<langle>Ia\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i Ib \<rightarrow>\<^sub>i Ib"
    "fold ::\<^sub>i (Ia\<rightarrow>\<^sub>iIb\<rightarrow>\<^sub>iIb) \<rightarrow>\<^sub>i \<langle>Ia\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i Ib \<rightarrow>\<^sub>i Ib"
    "take ::\<^sub>i i_nat \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_list"
    "drop ::\<^sub>i i_nat \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_list"
    "length ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i i_nat"
    "nth ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i i_nat \<rightarrow>\<^sub>i I"
    "hd ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i I"
    "tl ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_list"
    "last ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i I"
    "butlast ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_list"
    by auto
    *)

  lemma autoref_append[autoref_rules]:
    "(append, append)\<in>\<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel"
    by (auto simp: list_rel_def list_all2_appendI)

  lemma refine_list[autoref_rules]:
    "(Nil,Nil)\<in>\<langle>R\<rangle>list_rel"
    "(Cons,Cons)\<in>R \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel"
    "(case_list,case_list)\<in>Rr\<rightarrow>(R\<rightarrow>\<langle>R\<rangle>list_rel\<rightarrow>Rr)\<rightarrow>\<langle>R\<rangle>list_rel\<rightarrow>Rr"
    apply (force dest: fun_relD split: list.split)+
    done

  lemma autoref_rec_list[autoref_rules]: "(rec_list,rec_list)
    \<in> Ra \<rightarrow> (Rb \<rightarrow> \<langle>Rb\<rangle>list_rel \<rightarrow> Ra \<rightarrow> Ra) \<rightarrow> \<langle>Rb\<rangle>list_rel \<rightarrow> Ra"
  proof (intro fun_relI, goal_cases)
    case prems: (1 a a' f f' l l')
    from prems(3) show ?case
      using prems(1,2)
      apply (induct arbitrary: a a')
      apply simp
      apply (fastforce dest: fun_relD)
      done
  qed

  lemma refine_map[autoref_rules]:
    "(map,map)\<in>(R1\<rightarrow>R2) \<rightarrow> \<langle>R1\<rangle>list_rel \<rightarrow> \<langle>R2\<rangle>list_rel"
    using [[autoref_sbias = -1]]
    unfolding map_rec[abs_def]
    by autoref

  lemma refine_fold[autoref_rules]:
    "(fold,fold)\<in>(Re\<rightarrow>Rs\<rightarrow>Rs) \<rightarrow> \<langle>Re\<rangle>list_rel \<rightarrow> Rs \<rightarrow> Rs"
    "(foldl,foldl)\<in>(Rs\<rightarrow>Re\<rightarrow>Rs) \<rightarrow> Rs \<rightarrow> \<langle>Re\<rangle>list_rel \<rightarrow> Rs"
    "(foldr,foldr)\<in>(Re\<rightarrow>Rs\<rightarrow>Rs) \<rightarrow> \<langle>Re\<rangle>list_rel \<rightarrow> Rs \<rightarrow> Rs"
    unfolding List.fold_def List.foldr_def List.foldl_def
    by (autoref)+

  schematic_goal autoref_take[autoref_rules]: "(take,take)\<in>(?R::(_\<times>_) set)"
    unfolding take_def by autoref
  schematic_goal autoref_drop[autoref_rules]: "(drop,drop)\<in>(?R::(_\<times>_) set)"
    unfolding drop_def by autoref
  schematic_goal autoref_length[autoref_rules]:
    "(length,length)\<in>(?R::(_\<times>_) set)"
    unfolding size_list_overloaded_def size_list_def
    by (autoref)

  lemma autoref_nth[autoref_rules]:
    assumes "(l,l')\<in>\<langle>R\<rangle>list_rel"
    assumes "(i,i')\<in>Id"
    assumes "SIDE_PRECOND (i' < length l')"
    shows "(nth l i,(OP nth ::: \<langle>R\<rangle>list_rel \<rightarrow> Id \<rightarrow> R)$l'$i')\<in>R"
    unfolding ANNOT_def
    using assms
    apply (induct arbitrary: i i')
    apply simp
    apply (case_tac i')
    apply auto
    done

  fun list_eq :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
    "list_eq eq [] [] \<longleftrightarrow> True"
  | "list_eq eq (a#l) (a'#l')
       \<longleftrightarrow> (if eq a a' then list_eq eq l l' else False)"
  | "list_eq _ _ _ \<longleftrightarrow> False"

  lemma autoref_list_eq_aux: "
    (list_eq,list_eq) \<in>
      (R \<rightarrow> R \<rightarrow> Id) \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> Id"
  proof (intro fun_relI, goal_cases)
    case (1 eq eq' l1 l1' l2 l2')
    thus ?case
      apply -
      apply (induct eq' l1' l2' arbitrary: l1 l2 rule: list_eq.induct)
      apply simp
      apply (case_tac l1)
      apply simp
      apply (case_tac l2)
      apply (simp)
      apply (auto dest: fun_relD) []
      apply (case_tac l1)
      apply simp
      apply simp
      apply (case_tac l2)
      apply simp
      apply simp
      done
  qed

  lemma list_eq_expand[autoref_struct_expand]: "(=) = (list_eq (=))"
  proof (intro ext)
    fix l1 l2 :: "'a list"
    show "(l1 = l2) \<longleftrightarrow> list_eq (=) l1 l2"
      apply (induct "(=) :: 'a \<Rightarrow> _" l1 l2 rule: list_eq.induct)
      apply simp_all
      done
  qed

  lemma autoref_list_eq[autoref_rules (overloaded)]:
    "GEN_OP eq (=) (R\<rightarrow>R\<rightarrow>Id) \<Longrightarrow> (list_eq eq, (=))
    \<in> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> Id"
    unfolding autoref_tag_defs
    apply (subst list_eq_expand)
    apply (parametricity add: autoref_list_eq_aux)
    done

  lemma autoref_hd[autoref_rules]:
    "\<lbrakk> SIDE_PRECOND (l'\<noteq>[]); (l,l') \<in> \<langle>R\<rangle>list_rel \<rbrakk> \<Longrightarrow>
      (hd l,(OP hd ::: \<langle>R\<rangle>list_rel \<rightarrow> R)$l') \<in> R"
    apply (simp add: ANNOT_def)
    apply (cases l')
    apply simp
    apply (cases l)
    apply auto
    done

  lemma autoref_tl[autoref_rules]:
    "(tl,tl) \<in> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel"
    unfolding tl_def[abs_def]
    by autoref

  definition [simp]: "is_Nil a \<equiv> case a of [] \<Rightarrow> True | _ \<Rightarrow> False"

  lemma is_Nil_pat[autoref_op_pat]:
    "a=[] \<equiv> (OP is_Nil :::\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i i_bool)$a"
    "[]=a \<equiv> (OP is_Nil :::\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i i_bool)$a"
    by (auto intro!: eq_reflection split: list.splits)

  lemma autoref_is_Nil[param,autoref_rules]:
    "(is_Nil,is_Nil)\<in>\<langle>R\<rangle>list_rel \<rightarrow> bool_rel"
    by (auto split: list.splits)

  lemma conv_to_is_Nil:
    "l=[] \<longleftrightarrow> is_Nil l"
    "[]=l \<longleftrightarrow> is_Nil l"
    unfolding is_Nil_def by (auto split: list.split)

  lemma autoref_butlast[param, autoref_rules]:
    "(butlast,butlast) \<in> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel"
    unfolding butlast_def conv_to_is_Nil
    by parametricity

  definition [simp]: "op_list_singleton x \<equiv> [x]"
  lemma op_list_singleton_pat[autoref_op_pat]:
    "[x] \<equiv> (OP op_list_singleton :::\<^sub>i I \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_list)$x" by simp
  lemma autoref_list_singleton[autoref_rules]:
    "(\<lambda>a. [a],op_list_singleton) \<in> R \<rightarrow> \<langle>R\<rangle>list_rel"
    by auto

  definition [simp]: "op_list_append_elem s x \<equiv> s@[x]"

  lemma pat_list_append_elem[autoref_op_pat]:
    "s@[x] \<equiv> (OP op_list_append_elem :::\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_list)$s$x"
    by (simp add: relAPP_def)

  lemma autoref_list_append_elem[autoref_rules]:
    "(\<lambda>s x. s@[x], op_list_append_elem) \<in> \<langle>R\<rangle>list_rel \<rightarrow> R \<rightarrow> \<langle>R\<rangle>list_rel"
    unfolding op_list_append_elem_def[abs_def] by parametricity

  declare param_rev[autoref_rules]

  declare param_all_interval_nat[autoref_rules]

  lemmas [autoref_rules] = param_dropWhile param_takeWhile

end

subsection "Examples"

text \<open>Be careful to make the concrete type a schematic type variable.
  The default behaviour of \<open>schematic_lemma\<close> makes it a fixed variable,
  that will not unify with the infered term!\<close>
schematic_goal
  "(?f::?'c,[1,2,3]@[4::nat])\<in>?R"
  by autoref

schematic_goal
  "(?f::?'c,[1::nat,
    2,3,4,5,6,7,8,9,0,1,43,5,5,435,5,1,5,6,5,6,5,63,56
  ]
  )\<in>?R"
  apply (autoref)
  done

schematic_goal
  "(?f::?'c,[1,2,3] = [])\<in>?R"
  by autoref

text \<open>
  When specifying custom refinement rules on the fly, be careful with
  the type-inference between \<open>notes\<close> and \<open>shows\<close>. It's
  too easy to ,,decouple'' the type \<open>'a\<close> in the autoref-rule and
  the actual goal, as shown below!
\<close>

schematic_goal
  notes [autoref_rules] = IdI[where 'a="'a"]
  notes [autoref_itype] = itypeI[where 't="'a::numeral" and I=i_std]
  shows "(?f::?'c, hd [a,b,c::'a::numeral])\<in>?R"
  txt \<open>The autoref-rule is bound with type \<open>'a::typ\<close>, while
    the goal statement has \<open>'a::numeral\<close>!\<close>
  apply (autoref (keep_goal))
  txt \<open>We get an unsolved goal, as it finds no rule to translate
    \<open>a\<close>\<close>
  oops

text \<open>Here comes the correct version. Note the duplicate sort annotation
  of type \<open>'a\<close>:\<close>
schematic_goal
  notes [autoref_rules_raw] = IdI[where 'a="'a::numeral"]
  notes [autoref_itype] = itypeI[where 't="'a::numeral" and I=i_std]
  shows "(?f::?'c, hd [a,b,c::'a::numeral])\<in>?R"
  by (autoref)

text \<open>Special cases of equality: Note that we do not require equality
  on the element type!\<close>
schematic_goal
  (*notes [autoref_itype] = itypeI[of a "\<langle>I\<rangle>\<^sub>ii_option"]*)
  assumes [autoref_rules]: "(ai,a)\<in>\<langle>R\<rangle>option_rel"
  shows "(?f::?'c, a = None)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal
  (*notes [autoref_itype] = itypeI[of a "\<langle>I\<rangle>\<^sub>ii_list"]*)
  assumes [autoref_rules]: "(ai,a)\<in>\<langle>R\<rangle>list_rel"
  shows "(?f::?'c, [] = a)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal
  shows "(?f::?'c, [1,2] = [2,3::nat])\<in>?R"
  apply (autoref (keep_goal))
  done

end


theory README imports Main
begin

section \<open>HOLCF: A higher-order version of LCF based on Isabelle/HOL\<close>

text \<open>
  HOLCF is the definitional extension of Church's Higher-Order Logic with
  Scott's Logic for Computable Functions that has been implemented in the
  theorem prover Isabelle. This results in a flexible setup for reasoning
  about functional programs. HOLCF supports standard domain theory (in
  particular fixpoint reasoning and recursive domain equations) but also
  coinductive arguments about lazy datatypes.

  The most recent description of HOLCF is found here:

    \<^item> \<^emph>\<open>HOLCF '11: A Definitional Domain Theory for Verifying Functional
    Programs\<close> \<^url>\<open>http://web.cecs.pdx.edu/~brianh/phdthesis.html\<close>, Brian
    Huffman. Ph.D. thesis, Portland State University. 2012.

  Descriptions of earlier versions can also be found online:

    \<^item> \<^emph>\<open>HOLCF = HOL+LCF\<close> \<^url>\<open>https://www21.in.tum.de/~nipkow/pubs/jfp99.html\<close>

  A detailed description (in German) of the entire development can be found
  in:

    \<^item> \<^emph>\<open>HOLCF: eine konservative Erweiterung von HOL um LCF\<close>
    \<^url>\<open>http://www4.informatik.tu-muenchen.de/publ/papers/Diss_Regensbu.pdf\<close>,
    Franz Regensburger. Dissertation Technische Universität München. 1994.

  A short survey is available in:

    \<^item> \<^emph>\<open>HOLCF: Higher Order Logic of Computable Functions\<close>
    \<^url>\<open>http://www4.informatik.tu-muenchen.de/publ/papers/Regensburger_HOLT1995.pdf\<close>
\<close>

end


(* uses Isabelle2017 and autocorres version 1.0 *)
theory shortest_path_neg
  imports
  "checker-verification/Library/Autocorres_Misc"
  "checker-verification/Witness_Property/Connected_Components"
begin
(* Parse the input file. *)

install_C_file "shortest_path_neg.c"

autocorres "shortest_path_neg.c"

context shortest_path_neg begin

subsection {* Definitions *}

(* non-negative cost *)
thm "is_wellformed_body_def"
thm "trian_body_def"
thm "just_body_def"
thm "no_path_body_def"
thm "pos_cost_body_def"
thm "check_basic_just_sp_body_def"
thm "check_sp_body_def"

thm "is_wellformed'_def"
thm "trian'_def"
thm "just'_def"
thm "no_path'_def"
thm "pos_cost'_def"
thm "check_basic_just_sp'_def"
thm "check_sp'_def"

(* general cost *)

thm "s_assums_body_def"
thm "parent_num_assms_body_def"
thm "no_p_edge_body_def"
thm "source_val_body_def"
thm "no_edge_Vm_Vf_body_def"
thm "awalk_body_def"
thm "awalk_cost_body_def"
thm "C_se_body_def"
thm "int_neg_cyc_body_def"
thm "shortest_paths_locale_step1_body_def"
thm "shortest_paths_locale_step2_body_def"
thm "shortest_paths_locale_step3_body_def"

thm "s_assums'_def"
thm "parent_num_assms'_def"
thm "no_p_edge'_def"
thm "source_val'_def"
thm "no_edge_Vm_Vf'_def"
thm "awalk'_def"
thm "awalk_cost'_def"
thm "C_se'_def"
thm "int_neg_cyc'_def"
thm "shortest_paths_locale_step1'_def"
thm "shortest_paths_locale_step2'_def"
thm "shortest_paths_locale_step3'_def"

subsection {* Implementation Graph Types *}

type_synonym IVertex = "32 word"
type_synonym IEdge_Id = "32 word"
type_synonym IEdge = "IVertex \<times> IVertex"
type_synonym IPEdge = "IVertex \<Rightarrow> 32 word"
type_synonym INum = "IVertex \<Rightarrow> 32 word"
type_synonym IDist = "IVertex \<Rightarrow> 32 word \<times> 32 word"
type_synonym ICost = "IEdge_Id \<Rightarrow> 32 word"
type_synonym IGraph = "32 word \<times> 32 word \<times> (IEdge_Id \<Rightarrow> IEdge)"

abbreviation ivertex_cnt :: "IGraph \<Rightarrow> 32 word"
where
  "ivertex_cnt G \<equiv> fst G"

abbreviation iedge_cnt :: "IGraph \<Rightarrow> 32 word"
where
  "iedge_cnt G \<equiv> fst (snd G)"

abbreviation iedges :: "IGraph \<Rightarrow> IEdge_Id \<Rightarrow> IEdge"
where
  "iedges G \<equiv> snd (snd G)"

(* Make List - makes a list containing the result of a function *)
fun bool::"32 word \<Rightarrow> bool"
where
  "bool b = (if b=0 then False else True)"

fun mk_list' :: "nat \<Rightarrow> (32 word \<Rightarrow> 'b) \<Rightarrow> 'b list"
where
  "mk_list' n f = map f  (map of_nat [0..<n])"

fun mk_list'_temp :: "nat \<Rightarrow> (32 word \<Rightarrow> 'b) \<Rightarrow> nat \<Rightarrow> 'b list"
where
  "mk_list'_temp 0 _ _ = []" |
  "mk_list'_temp (Suc x) f i = (f (of_nat i)) # mk_list'_temp x f (Suc i)"

subsection {* Make graph lists *}

fun mk_iedge_list :: "IGraph \<Rightarrow> IEdge list"
where
  "mk_iedge_list G = mk_list' (unat (iedge_cnt G)) (iedges G)"

fun mk_inum_list :: "IGraph \<Rightarrow> INum \<Rightarrow> 32 word list"
where
  "mk_inum_list G num = mk_list' (unat (ivertex_cnt G)) num"

fun mk_ipedge_list :: "IGraph \<Rightarrow> IPEdge \<Rightarrow> 32 word list"
where
  "mk_ipedge_list G pedge = mk_list' (unat (ivertex_cnt G)) pedge"

fun mk_icost_list :: "IGraph \<Rightarrow> ICost \<Rightarrow> 32 word list"
where
  "mk_icost_list G cost = mk_list' (unat (iedge_cnt G)) cost"

fun mk_idist_list :: "IGraph \<Rightarrow> IDist \<Rightarrow> (32 word \<times> 32 word) list"
where
  "mk_idist_list G dis = mk_list' (unat (ivertex_cnt G)) dis"

subsection {* Equate to Implementation *}
fun to_edge :: "IEdge \<Rightarrow> Edge_C"
where
  "to_edge (u,v) = Edge_C u v"

fun to_enat :: "(32 word \<times> 32 word) \<Rightarrow> enat_C"
where
  "to_enat (a,b) = enat_C (scast a) (scast b)"

lemma first_C_pte[simp]:
  "first_C (to_edge e) = fst e"
  by (cases e) auto

lemma second_C_pte[simp]:
  "second_C (to_edge e) = snd e"
  by (cases e) auto

lemma val_C_pte[simp]:
  "val_C (to_enat n) = scast (fst n)"
  by (cases n) auto

lemma inf_status_C_pte[simp]:
  "inf_status_C (to_enat n) = scast (snd n)"
  by (cases n) auto

definition is_graph
  where
  "is_graph h iG p \<equiv>
    is_valid_Graph_C h p \<and>
    ivertex_cnt iG = num_vertices_C (heap_Graph_C h p) \<and>
    iedge_cnt iG = num_edges_C (heap_Graph_C h p) \<and>
    arrlist (heap_Edge_C h) (is_valid_Edge_C h)
      (map to_edge (mk_iedge_list iG)) (arcs_C (heap_Graph_C h p))"

definition is_numm
  where
  "is_numm h iG iN p \<equiv> arrlist (heap_w32 h) (is_valid_w32 h) (mk_inum_list iG iN) p"

definition is_pedge
  where
  "is_pedge h iG iP (p:: 32 signed word ptr) \<equiv> arrlist (\<lambda>p. heap_w32 h (ptr_coerce p))
        (\<lambda>p. is_valid_w32 h (ptr_coerce p)) (mk_ipedge_list iG iP) p"

definition is_cost
  where
  "is_cost h iG iC (p:: 32 signed word ptr) \<equiv> arrlist (\<lambda>p. heap_w32 h (ptr_coerce p))
        (\<lambda>p. is_valid_w32 h (ptr_coerce p)) (mk_icost_list iG iC) p"

definition is_dist
  where
  "is_dist h iG iD (p:: enat_C ptr) \<equiv> arrlist (\<lambda>p. heap_enat_C h (ptr_coerce p))
        (\<lambda>p. is_valid_enat_C h (ptr_coerce p)) (map to_enat (mk_idist_list iG iD)) p"

subsection {* Abstract Graph *}

definition no_loops :: "('a, 'b) pre_digraph \<Rightarrow> bool"
where
  "no_loops G \<equiv> \<forall>e \<in> arcs G. tail G e \<noteq> head G e"

definition abs_IGraph :: "IGraph \<Rightarrow> (32 word, 32 word) pre_digraph"
where
  "abs_IGraph G \<equiv> \<lparr> verts = {0..<ivertex_cnt G}, arcs = {0..<iedge_cnt G},
    tail = fst o iedges G, head = snd o iedges G \<rparr>"

lemma verts_absI[simp]: "verts (abs_IGraph G) = {0..<ivertex_cnt G}"
  and edges_absI[simp]: "arcs (abs_IGraph G) = {0..<iedge_cnt G}"
  and start_absI[simp]: "tail (abs_IGraph G) e = fst (iedges G e)"
  and target_absI[simp]: "head (abs_IGraph G) e = snd (iedges G e)"
  by (auto simp: abs_IGraph_def)

definition abs_pedge :: "(32 word \<Rightarrow> 32 word) \<Rightarrow> 32 word \<Rightarrow> 32 word option"
where
  "abs_pedge p \<equiv> (\<lambda>v. if sint (p v) < 0 then None else Some (p v))"

lemma None_abs_pedgeI[simp]:
  "((abs_pedge p) v = None) = (sint (p v) < 0)"
  using abs_pedge_def by auto

lemma Some_abs_pedgeI[simp]:
  "(\<exists>e. (abs_pedge p) v = Some e) = (sint (p v) \<ge> 0)"
  using None_not_eq None_abs_pedgeI
  by (metis abs_pedge_def linorder_not_le option.simps(3))

subsection {* Helper Lemmas *}

lemma wellformed_iGraph:
  assumes "wf_digraph (abs_IGraph G)"
  shows "\<And>e. e < iedge_cnt G \<Longrightarrow>
        fst (iedges G e) < ivertex_cnt G \<and>
        snd (iedges G e) < ivertex_cnt G"
  using assms unfolding wf_digraph_def by simp

lemma unat_image_upto:
  fixes n :: "32 word"
  shows "unat ` {0..<n} = {unat 0..<unat n}" (is "?A = ?B")
proof
  show "?B \<subseteq> ?A"
  proof
    fix i assume a: "i \<in> ?B"
    then obtain i':: "32 word" where ii: "i=  unat i'"
      by (metis atLeastLessThan_iff le_unat_uoi less_or_eq_imp_le)
    then have "i' \<in> {0..<n}"
      using a word_less_nat_alt by auto
    thus  "i \<in> ?A" using ii by fast
  qed
next
  show "?A \<subseteq> ?B"
  proof
     fix i assume a: "i \<in> ?A"
    then obtain i':: "32 word" where ii: "i=  unat i'" by blast
    then have "i' \<in> {0..<n}" using a by force
    thus  "i \<in> ?B"
      by (metis Un_iff atLeast0LessThan ii ivl_disj_un(8)
          lessThan_iff unat_0 unat_mono word_zero_le)
  qed
qed

lemma path_length:
  assumes "vpath p (abs_IGraph iG)"
  shows "vwalk_length p < unat (ivertex_cnt iG)"
proof -
  have pne: "p \<noteq> []" and dp: "distinct p" using assms by fast+
  have "unat (ivertex_cnt iG) = card (unat ` {0..<(fst iG)})"
    using unat_image_upto by simp
  then have "unat (ivertex_cnt iG) = card ((verts (abs_IGraph iG)))"
     by (simp add: inj_on_def card_image)
  hence "length p  \<le> unat (ivertex_cnt iG)"
      by (metis finite_code card_mono vwalk_def
          distinct_card[OF dp] vpath_def assms)
  hence "length p - 1 < unat (ivertex_cnt iG)"
    by (metis pne Nat.diff_le_self le_neq_implies_less
        less_imp_diff_less minus_eq one_neq_zero length_0_conv)
  thus "vwalk_length p < unat (fst iG)"
    using  assms
    unfolding vpath_def vwalk_def by simp
qed

lemma ptr_coerce_ptr_add_uint[simp]:
  "ptr_coerce (p +\<^sub>p uint x) =  p +\<^sub>p  (uint x)"
  by auto

lemma edge_heap:
  "\<lbrakk> arrlist h v (map (to_edge \<circ> (iedges iG \<circ> of_nat)) [0..<unat m]) ep;
  e < m\<rbrakk> \<Longrightarrow> to_edge ((iedges iG) e) = h (ep +\<^sub>p (int (unat e)))"
  apply (subgoal_tac "h (ep +\<^sub>p (int (unat e))) =
  (map (to_edge \<circ> (iedges iG \<circ> of_nat)) [0..<unat m]) ! unat e")
   apply (subgoal_tac "to_edge ((iedges iG) e) =
   (map (to_edge \<circ> (iedges iG \<circ> of_nat)) [0..<unat m]) ! unat e")
    apply presburger
   apply (metis (hide_lams, mono_tags) length_map length_upt o_apply
      map_upt_eq_vals_D minus_nat.diff_0 unat_mono word_unat.Rep_inverse)
  apply (fastforce simp: unat_mono arrlist_nth_value)
  done

lemma head_heap:
  "\<lbrakk>arrlist h v (map (to_edge \<circ> (iedges iG \<circ> of_nat)) [0..<unat m]) ep; e < m\<rbrakk> \<Longrightarrow>
  snd ((iedges iG) e) = second_C (h (ep +\<^sub>p (uint e)))"
  using edge_heap to_edge.simps second_C_pte by (metis uint_nat)

lemma tail_heap:
  "\<lbrakk>arrlist h v (map (to_edge \<circ> (iedges iG \<circ> of_nat)) [0..<unat m]) ep; e < m\<rbrakk> \<Longrightarrow>
  fst ((iedges iG) e) =  first_C (h (ep +\<^sub>p  (uint e)))"
  using edge_heap to_edge.simps first_C_pte uint_nat by metis

subsection {* Verification *}

definition is_wellformed_inv :: "IGraph \<Rightarrow> 32 word \<Rightarrow> bool"
  where
  "is_wellformed_inv G i \<equiv> \<forall>k < i. ivertex_cnt G > fst (iedges G k)
        \<and> ivertex_cnt G > snd (iedges G k)"

lemma is_wellformed_spc':
  "\<lbrace> P and
     (\<lambda>s. wf_digraph (abs_IGraph iG) \<and>
          is_graph s iG g) \<rbrace>
   is_wellformed' g
   \<lbrace> (\<lambda>_ s. P s) And
     (\<lambda>rr s. rr \<noteq> 0 \<longleftrightarrow> is_wellformed_inv iG (iedge_cnt iG)) \<rbrace>!"
  apply (clarsimp simp: is_wellformed'_def)
  apply (subst whileLoopE_add_inv [where
        M="\<lambda>(ee, s). unat (iedge_cnt iG - ee)" and
        I="\<lambda>ee s. P s \<and> is_wellformed_inv iG ee \<and>
                   ee \<le> iedge_cnt iG \<and>
                   is_graph s iG g"])
  apply (simp add: skipE_def)
  apply wp
  unfolding is_graph_def is_wellformed_inv_def
    apply (subst if_bool_eq_conj)+
    apply (simp split: if_split_asm, safe, simp_all add: arrlist_nth)
         apply (rule_tac x = "ee" in exI)
         apply (subgoal_tac "num_vertices_C (heap_Graph_C s g) \<le> fst (snd (snd iG) ee)")
          apply force
         apply (subgoal_tac "first_C (heap_Edge_C s (arcs_C (heap_Graph_C s g) +\<^sub>p uint ee)) = fst (snd (snd iG) ee)")
          apply simp
         apply (subst tail_heap[where iG=iG], simp)
          apply blast
         apply blast
        apply(rule_tac x = "ee" in exI)
        apply (subgoal_tac "num_vertices_C (heap_Graph_C s g) \<le> snd (snd (snd iG) ee)")
         apply force
        apply (subgoal_tac "second_C (heap_Edge_C s (arcs_C (heap_Graph_C s g) +\<^sub>p uint ee)) = snd (snd (snd iG) ee)")
         apply simp
        apply (subst head_heap[where iG=iG], simp)
         apply blast
        apply blast
       apply (metis edge_heap first_C_pte le_cases le_step uint_nat word_le_less_eq)
      apply (metis head_heap le_step not_less)
     apply (simp add: le_step word_not_le)
  using le_step not_less
     apply blast
    apply (metis (mono_tags, hide_lams) diff_diff_add diff_self_eq_0 eq_iff_diff_eq_0 measure_unat not_less0 word_less_nat_alt zero_less_diff)
   apply (rule arrlist_nth, (simp add: uint_nat unat_mono)+)
  apply wp
  apply fast
  done

definition trian_inv :: "IGraph \<Rightarrow> IDist \<Rightarrow> ICost \<Rightarrow> 32 word \<Rightarrow> bool"
  where
  "trian_inv G d c m \<equiv>
    \<forall>i < m. snd (d (snd (iedges G i))) = 0 \<and>
            snd (d (fst (iedges G i))) = 0 \<and>
            fst (d (snd (iedges G i))) \<le> fst (d (fst (iedges G i))) + c i"

lemma trian_spc':
  "\<lbrace> P and
     (\<lambda>s. wf_digraph (abs_IGraph iG) \<and>
          is_graph s iG g \<and>
          is_dist s iG iD d \<and>
          is_cost s iG iC c)\<rbrace>
   trian' g d c
   \<lbrace> (\<lambda>_ s. P s) And
     (\<lambda>rr s. rr \<noteq> 0 \<longleftrightarrow> trian_inv iG iD iC (iedge_cnt iG)) \<rbrace>!"
  apply (clarsimp simp: trian'_def)
  apply (subst whileLoopE_add_inv [where
        M="\<lambda>(ee, s). unat (iedge_cnt iG - ee)" and
        I="\<lambda>ee s. P s \<and> trian_inv iG iD iC ee \<and>
                   ee \<le> iedge_cnt iG \<and>
                   wf_digraph (abs_IGraph iG) \<and>
                   is_graph s iG g \<and>
                   is_dist s iG iD d \<and>
                   is_cost s iG iC c"])
  apply (simp add: skipE_def)
  apply wp
  unfolding is_graph_def is_dist_def is_cost_def trian_inv_def
    apply (subst if_bool_eq_conj)+
    apply (simp split: if_split_asm, safe, simp_all add: arrlist_nth)
                    apply (rule_tac x = "ee" in exI)
                    apply (subgoal_tac "snd (iD (snd (snd (snd iG) ee))) = inf_status_C (heap_enat_C s (d +\<^sub>p uint (second_C (heap_Edge_C s (arcs_C (heap_Graph_C s g) +\<^sub>p uint ee)))))")

  sorry

end

end


section \<open> Differential Dynamic Logic \<close>

theory utp_hyprog_dL
  imports utp_hyprog_ode
begin

subsection \<open> dL Rules \<close>

theorem dWeakening: \<comment> \<open> Differential Weakening \<close>
  "`B \<Rightarrow> C` \<Longrightarrow> \<^bold>{A\<^bold>}ode F' B\<^bold>{C\<^bold>}"
  by (rel_simp, simp add: lit.rep_eq uexpr_appl.rep_eq)

lemma hoare_ode_meaning:
  "\<lbrace>P\<rbrace>ode F' B\<lbrace>Q\<rbrace>\<^sub>u =
    (\<forall> s F l. \<lbrakk>P\<rbrakk>\<^sub>e \<lparr> cvec\<^sub>v = F 0, \<dots> = s \<rparr>
            \<and> l \<ge> 0 \<and> solves F \<lbrakk>F'\<rbrakk>\<^sub>e B s l
            \<longrightarrow> \<lbrakk>Q\<rbrakk>\<^sub>e \<lparr>cvec\<^sub>v = F l, \<dots> = s\<rparr>)"
  by (rel_auto', blast)

theorem dCut:
  fixes B :: "('c::executable_euclidean_space, 's) hypred"
  assumes "\<lbrace>P\<rbrace>ode F' B\<lbrace>C\<rbrace>\<^sub>u" "\<lbrace>P\<rbrace>ode F' (B \<and> C)\<lbrace>Q\<rbrace>\<^sub>u"
  shows "\<lbrace>P\<rbrace>ode F' B\<lbrace>Q\<rbrace>\<^sub>u"
proof (simp add: hoare_ode_meaning, clarsimp)
  fix s :: "'s" and F :: "real \<Rightarrow> 'c" and l :: "real"
  assume a: "0 \<le> l" "solves F \<lbrakk>F'\<rbrakk>\<^sub>e B s l" "\<lbrakk>P\<rbrakk>\<^sub>e \<lparr> cvec\<^sub>v = F 0, \<dots> = s \<rparr>"
  have "\<forall> t\<in>{0..l}. \<lbrakk>C\<rbrakk>\<^sub>e \<lparr>cvec\<^sub>v = F t, \<dots> = s\<rparr>"
  proof (clarsimp)
    fix t
    assume b: "0 \<le> t" "t \<le> l"
    from a(1,2) b assms(1) show "\<lbrakk>C\<rbrakk>\<^sub>e (\<lparr>cvec\<^sub>v = F t, \<dots> = s\<rparr>)"
      apply (simp add: hoare_ode_meaning)
      apply (drule_tac x="s" in spec)
      apply (drule_tac x="F" in spec)
      apply (drule_tac x="t" in spec)
      apply (simp)
      using a(2) a(3) has_vector_derivative_within_subset apply fastforce
      done
  qed
  with a(1,2,3) assms(2) show "\<lbrakk>Q\<rbrakk>\<^sub>e \<lparr>cvec\<^sub>v = F l, \<dots> = s\<rparr>"
    apply (simp add: hoare_ode_meaning)
    apply (drule_tac x="s" in spec)
    apply (drule_tac x="F" in spec)
    apply (drule_tac x="l" in spec)
    apply (rel_auto')
    using a(2) apply auto
    done
qed

lemma solves_ode_solves:
  "(F solves_ode (\<lambda> t. F')) UNIV UNIV \<Longrightarrow> solves F F' true s l"
  by (auto simp add: solves_ode_def has_vderiv_on_def, rel_simp)

(*
lemma
  assumes
    "\<forall> l. (F solves_ode (\<lambda> t. \<lbrakk>F'\<rbrakk>\<^sub>e)) {0..l} UNIV"
    "\<forall> t s. \<lbrakk>P\<rbrakk>\<^sub>e \<lparr> cvec\<^sub>v = F 0, \<dots> = s \<rparr> \<longrightarrow> \<lbrakk>P\<rbrakk>\<^sub>e \<lparr> cvec\<^sub>v = F t, \<dots> = s \<rparr>"
  shows "\<lbrace>P\<rbrace>ode F' B\<lbrace>P\<rbrace>\<^sub>u"
proof -
  have "\<forall> s l. solves F \<lbrakk>F'\<rbrakk>\<^sub>e true s l"
    by (meson assms(1) solves_ode_solves)
  with assms(2) show ?thesis
    apply (simp add: hoare_ode_meaning)
    apply (auto)
*)

end


theory Combine_Opt_Ext
  imports
    Combine_Opt
    Balance_Opt_LR_Ext
    "../../Assertion_Tree_Lookup"
    "../../Utilities_Ext"
begin

context rbt_impl
begin

lemma disjoint_trees_ptr_map_add_graph [simp]:
  assumes "rbt_of l |\<guillemotleft> k" and "k \<guillemotleft>| rbt_of r"
  shows
    "Map.graph (ptr_of_key l li ++ ptr_of_key r ri) =
         Map.graph (ptr_of_key l li) \<union> Map.graph (ptr_of_key r ri)"
  unfolding map_add_def Map.graph_def
  apply (rule equalityI)
  subgoal by (auto split: option.splits)
  subgoal
    apply (auto split: option.splits)
    by (metis assms linorder_not_less option.distinct(1)
        ptr_of_key_greater_none ptr_of_key_less_none
        rbt_greater_trans rbt_less_eq_trans)
  done

lemma disjoint_trees_value_map_add_graph [simp]:
  assumes "rbt_of l |\<guillemotleft> k" and "k \<guillemotleft>| rbt_of r"
  shows
    "Map.graph (value_of_key l ++ value_of_key r) =
         Map.graph (value_of_key l) \<union> Map.graph (value_of_key r)"
  unfolding map_add_def Map.graph_def
  apply (rule equalityI)
  subgoal by (auto split: option.splits)
  subgoal
    apply (auto split: option.splits)
    by (metis assms linorder_not_less option.distinct(1)
        value_of_key_greater_none value_of_key_less_none
        rbt_greater_trans rbt_less_eq_trans)
  done

lemma combine_correct_ext':
  "
  llvm_htriple
  (rbt_assn_ext l {} li ** rbt_assn_ext r {} ri **
   \<up>(rbt_sorted (rbt_of l)) ** \<up>(rbt_sorted (rbt_of r)) ** \<up>(rbt_of l |\<guillemotleft> k \<and> k \<guillemotleft>| rbt_of r))
  (combine_opt li ri)
  (\<lambda>ti_res. EXS t_res.
    rbt_assn_ext t_res {} ti_res **
    ctx(rbt_of t_res = rbt_combine (rbt_of l) (rbt_of r)) **
    ctx(rbt_sorted (rbt_of t_res)) **
    \<up>(ptr_of_key t_res ti_res = ptr_of_key l li ++ ptr_of_key r ri) **
    \<up>(value_of_key t_res = value_of_key l ++ value_of_key r)
  )
  "
proof(induction "rbt_of l" "rbt_of r" arbitrary: l r li ri rule: RBT_Impl.combine.induct)
  case 1
  then show ?case
    apply (subst combine_opt.simps)
    apply vcg_vok
    done
next
  case (2 v va vb vc vd)
  then show ?case
    apply (subst combine_opt.simps)
    apply vcg_vok
    done
next
  case (3 a k x b c s y d)
  note 3(1)[simplified ctx_def, vcg_rules]

  from 3(2-3) show ?case
    supply
      RBT_Impl.combine.simps[simp del]
      combine_rbt_sorted[simp]

    apply (subst combine_opt.simps)
    apply vcg
    subgoal
      apply resolve_rbt_pat_mat
      subgoal
        apply vcg_compat
        apply sepE
         apply (auto simp add: RBT_Impl.combine.simps)[]

        apply sep
         apply (simp add: combine_rbt_sorted)

        apply sep
        subgoal
          apply (simp add: ptr_of_key_simps)
          apply pok_solver
          done
        apply sep
        subgoal
          apply (simp add: value_of_key_simps)
          apply vok_solver
          done
        apply simp
        apply sep
        done
      done
    subgoal
      apply vcg
      apply vcg_compat

      apply sepE (*rbt_of*)

       apply (cases "rbt_combine b c")
        apply (auto simp add: RBT_Impl.combine.simps split: color.splits)[2]

      apply sep (*sorted*)
       apply simp

      apply sep
      subgoal
        apply (simp add: ptr_of_key_simps)
        apply pok_solver
        done

      apply sep
      subgoal
        apply (simp add: value_of_key_simps)
        apply vok_solver
        done

      apply simp
      apply sep
      done
    done
next
  case (4 a k x b c s y d)
  note 4(1)[simplified ctx_def, vcg_rules]

  from 4(2-3) show ?case
    supply
      RBT_Impl.combine.simps[simp del]
      combine_rbt_sorted[simp]

    apply (subst combine_opt.simps)
    apply vcg
    subgoal
      apply resolve_rbt_pat_mat
      apply vcg_compat

      apply sepE
       apply (auto simp add: RBT_Impl.combine.simps)[] (*rbt_of*)

      apply sep (*sorted*)
       apply simp

      apply sep (*pok*)
      subgoal
        apply (simp add: ptr_of_key_simps)
        apply pok_solver
        done

      apply sep (*vok*)
      subgoal
        apply (simp add: value_of_key_simps)
        apply vok_solver
        done

      apply simp
      apply sep
      done

    subgoal
      supply
        rbt_less_trans[intro]
        rbt_greater_trans[intro]
        combine_rbt_greater[intro]
        combine_rbt_less[intro]
      apply vcg
      apply vcg_compat

      apply sepE
      apply (cases "rbt_combine b c")
      apply (auto simp add: RBT_Impl.combine.simps split: color.splits)[2]

      apply sep
       apply simp

      apply sep
      apply (simp add: ptr_of_key_simps)
      apply pok_solver

      apply sep
      apply (simp add: value_of_key_simps)
      apply vok_solver

      apply sep
      done
    done
next
  case (5 va vb vc vd b k x c)
  note 5(1)[simplified ctx_def, vcg_rules]
  from 5(2-3) show ?case
    supply
      RBT_Impl.combine.simps[simp del]
      combine_rbt_sorted[simp]

    apply (subst combine_opt.simps)
    apply vcg
    apply vcg_compat
    subgoal
      supply
        rbt_less_trans[intro]
        rbt_greater_trans[intro]

      apply sepE
       apply (simp add: RBT_Impl.combine.simps)

      apply sep
       apply simp

      apply sep
       apply (simp add: ptr_of_key_simps)
       apply pok_solver

      apply sep
       apply (simp add: value_of_key_simps)
       apply vok_solver

      apply simp
      apply sep
      done
    done
next
  case (6 a k x b va vb vc vd)
  note 6(1)[simplified ctx_def, vcg_rules]
  from 6(2-3) show ?case
    supply
      RBT_Impl.combine.simps[simp del]
      combine_rbt_sorted[simp]

    apply (subst combine_opt.simps)
    apply vcg
    apply vcg_compat
    subgoal
      supply
        rbt_less_trans[intro]
        rbt_greater_trans[intro]

      apply sepE
       apply (simp add: RBT_Impl.combine.simps)

      apply sep
       apply simp

      apply sep
       apply (simp add: ptr_of_key_simps)
       apply pok_solver

      apply sep
       apply (simp add: value_of_key_simps)
       apply vok_solver

      apply simp
      apply sep
      done
    done
qed

lemmas combine_correct_ext[vcg_rules] = combine_correct_ext'[simplified ctx_def]

end

end


section \<open>Common Proof Methods and Idioms\<close>
theory Idioms
imports "../Sep_Main" Open_List Circ_List Hash_Set_Impl
begin
text_raw\<open>\label{thy:ex:idioms}\<close>

  text \<open>
    This theory gives a short documentation of common proof techniques and
    idioms for the separation logic framework. For this purpose, it presents
    some proof snippets (inspired by the other example theories), and heavily
    comments on them.
\<close>

  subsection \<open>The Method \<open>sep_auto\<close>\<close>
  text \<open>The most versatile method of our framework is \<open>sep_auto\<close>,
    which integrates the verification condition generator, the entailment
    solver and some pre- and postprocessing tactics based on the simplifier
    and classical reasoner. It can be applied to a Hoare-triple or entailment
    subgoal, and will try to solve it, and any emerging new goals. It stops
    when the goal is either solved or it gets stuck somewhere.\<close>

  text \<open>As a simple example for \<open>sep_auto\<close> consider the following
    program that does some operations on two circular lists:\<close>
  definition "test \<equiv> do {
    l1 \<leftarrow> cs_empty;
    l2 \<leftarrow> cs_empty;
    l1 \<leftarrow> cs_append ''a'' l1;
    l2 \<leftarrow> cs_append ''c'' l2;
    l1 \<leftarrow> cs_append ''b'' l1;
    l2 \<leftarrow> cs_append ''e'' l2;
    l2 \<leftarrow> cs_prepend ''d'' l2;
    l2 \<leftarrow> cs_rotate l2;
    return (l1,l2)
  }"

  text \<open>The \<open>sep_auto\<close> method does all the
    necessary frame-inference automatically, and thus manages to prove
    the following lemma in one step:\<close>
  lemma "<emp>
    test
    <\<lambda>(l1,l2). cs_list [''a'',''b''] l1
      * cs_list [''c'',''e'',''d''] l2>\<^sub>t"
    unfolding test_def
    apply (sep_auto)
    done

  text \<open>\<open>sep_auto\<close> accepts all the section-options of the classical
    reasoner and simplifier, e.g., \<open>simp add/del:\<close>, \<open>intro:\<close>.
    Moreover, it has some more section options, the most useful being
    \<open>heap add/del:\<close> to add or remove Hoare-rules that are applied
    with frame-inference. A complete documentation of the accepted options can
    be found in Section~\ref{sec:auto:overview}.
\<close>

  text \<open>As a typical example, consider the following proof:\<close>
  lemma complete_ht_rehash:
    "<is_hashtable l ht> ht_rehash ht
    <\<lambda>r. is_hashtable l ht * is_hashtable (ls_rehash l) r>"
  proof -
    have LEN: " l \<noteq> [] \<Longrightarrow> Suc 0 < 2 * length l" by (cases l) auto
    show ?thesis
      apply (rule cons_pre_rule[OF ht_imp_len])
      unfolding ht_rehash_def
      apply (sep_auto
        heap: complete_ht_new_sz complete_ht_copy
        simp: ls_rehash_def LEN
      ) \<comment> \<open>Here we add a heap-rule, and some simp-rules\<close>
      done
  qed

  subsection \<open>Applying Single Rules\<close>
  text \<open>\paragraph{Hoare Triples} In this example, we show how to do
    a proof step-by-step.\<close>

  lemma
    "<os_list xs n> os_prepend x n <os_list (x # xs)>"
    unfolding os_prepend_def
    txt \<open>The rules to deconstruct compound statements are contained in the
      \<open>sep_decon_rules\<close> collection\<close>
    thm sep_decon_rules
    apply (rule sep_decon_rules)
    txt \<open>The rules for statement that deend on the heap are
      contained in the \<open>sep_heap_rules\<close> collection. The
      \<open>fi_rule\<close>-lemma prepares frame inference for them\<close>
    apply (rule sep_heap_rules[THEN fi_rule])
    apply frame_inference \<comment> \<open>This method does the frame-inference\<close>

    txt \<open>The consequence rule comes in three versions,
      \<open>const_rule\<close>, \<open>cons_pre_rule\<close>,
      and \<open>cons_post_rule\<close>\<close>
    apply (rule cons_post_rule)
    apply (rule sep_decon_rules)

    txt \<open>A simplification unfolds \<open>os_list\<close> and extract the
      pure part of the assumption\<close>
    apply (clarsimp)

    txt \<open>We can use \<open>ent_ex_postI\<close> to manually introduce
      existentials in entailsments\<close>
    apply (rule_tac x=xa in ent_ex_postI)
    apply (rule_tac x=n in ent_ex_postI)
    txt \<open>The simplifier has a setup for assertions, so it will do the rest\<close>
    apply simp
    done

  text \<open>Note that the proof above can be done with \<open>sep_auto\<close>,
    the "Swiss army knife" of our framework\<close>
  lemma
    "<os_list xs n> os_prepend x n <os_list (x # xs)>"
    unfolding os_prepend_def by sep_auto

  text \<open>\paragraph{Entailment} This example presents an actual proof
    from the circular list theory, where we have to manually apply a
    rule and give some hints to frame inference\<close>
  lemma cs_append_rule:
    "<cs_list l p> cs_append x p <cs_list (l@[x])>"
    apply (cases p)
    apply (sep_auto simp: cs_append.simps)

    apply (sep_auto simp: cs_append.simps heap: lseg_append)
    txt \<open>At this point, we are left with an entailment subgoal that sep-auto
      cannot solve. A closer look reveals that we could use the rule
      \<open>lseg_append\<close>.

      With the \<open>ent_frame_fwd\<close>-rule, we can manually apply a rule to
      solve an entailment, involving frame inference. In this case, we have
      the additional problem that frame-inference guesses
      a wrong instantiation, and is not able to infer the frame.
      So we have to pre-instantiate the rule, as done below.\<close>
    apply (rule_tac s1=pp in ent_frame_fwd[OF lseg_append])
    apply frame_inference \<comment> \<open>Now frame-inference is able to infer the frame\<close>

    txt \<open>Now we are left with a trivial entailment, modulo commutativity of
      star. This can be handled by the entailment solver:\<close>
    apply solve_entails
    done

  subsection \<open>Functions with Explicit Recursion\<close>
  text \<open>If the termination argument of a function depends on one of
    its parameters, we can use the function package. For example,
    the following function inserts elements from a list into a hash-set:\<close>

  fun ins_from_list
    :: "('x::{heap,hashable}) list \<Rightarrow> 'x hashset \<Rightarrow> 'x hashset Heap"
    where
    "ins_from_list [] hs = return hs" |
    "ins_from_list (x # l) hs = do { hs \<leftarrow> hs_ins x hs; ins_from_list l hs }"

  text \<open>Proofs over such functions are usually done by structural
    induction on the explicit parameter, in this case, on the list\<close>
  lemma ins_from_list_correct:
    "<is_hashset s hs> ins_from_list l hs <is_hashset (s\<union>set l)>\<^sub>t"
  proof (induction l arbitrary: hs s)
    case (Cons x l)
    txt \<open>In the induction step, the induction hypothesis has to be
      declared as a heap-rule, as \<open>sep_auto\<close> currently does not
      look for potential heap-rules among the premises of the subgoal\<close>
    show ?case by (sep_auto heap: Cons.IH)
  qed sep_auto

  subsection \<open>
    Functions with Recursion Involving the Heap
\<close>
  text \<open>If the termination argument of a function depends on data stored on
    the heap, \<open>partial_function\<close> is a useful tool.

    Note that, despite the name, proving a Hoare-Triple \<open><\<dots>> \<dots> <\<dots>>\<close>
    for something defined with \<open>partial_function\<close> implies total
    correctness.
\<close>

  text \<open>In the following example, we compute the sum of a list, using an
    iterator. Note that the partial-function package does not provide a
    code generator setup by default, so we have to add a \<open>[code]\<close>
    attribute manually\<close>
  partial_function (heap) os_sum' :: "int os_list_it \<Rightarrow> int \<Rightarrow> int Heap"
    where [code]:
    "os_sum' it s = do {
      b \<leftarrow> os_it_has_next it;
      if b then do {
        (x,it') \<leftarrow> os_it_next it;
        os_sum' it' (s+x)
      } else return s
    }"

  text \<open>The proof that the function is correct can be done by induction
    over the representation of the list that we still have to iterate over.
    Note that for iterators over sets, we need induction on finite sets,
    cf. also \<open>To_List_Ga.thy\<close>\<close>

  lemma os_sum'_rule:
    "<os_is_it l p l' it>
    os_sum' it s
    <\<lambda>r. os_list l p * \<up>(r = s + sum_list l')>\<^sub>t"
  proof (induct l' arbitrary: it s)
    case Nil thus ?case
      txt \<open>To unfold the definition of a partial function, we have to use
        \<open>subst\<close>. Note that \<open>simp\<close> would loop, unfolding the
        function arbitrarily deep\<close>
      apply (subst os_sum'.simps)
      txt \<open>\<open>sep_auto\<close> accepts all the section parameters that
        \<open>auto\<close> does, eg. \<open>intro:\<close>\<close>
      apply (sep_auto intro: os.quit_iteration)
      done
  next
    case (Cons x l')
    show ?case
      apply (subst os_sum'.simps)
      txt \<open>Additionally, \<open>sep_auto\<close> accepts some more section
        parameters. The most common one, \<open>heap:\<close>, declares rules
        to be used with frame inference. See Section~\ref{sec:auto:overview}
        for a complete overview.\<close>
      apply (sep_auto heap: Cons.hyps)
      done
  qed

  subsection \<open>Precision Proofs\<close>
  text \<open>
    Precision lemmas show that an assertion uniquely determines some of its
    parameters. Our example shows that two list segments from the same start
    pointer and with the same list, also have to end at the same end pointer.
\<close>

  lemma lseg_prec3:
    "\<forall>q q'. h \<Turnstile> (lseg l p q * F1) \<and>\<^sub>A (lseg l p q' * F2) \<longrightarrow> q=q'"
    apply (intro allI)
  proof (induct l arbitrary: p F1 F2)
    case Nil thus ?case
      apply simp \<comment> \<open>A precision solver for references and arrays is included
        in the standard simplifier setup. Building a general precision solver
        remains future work.\<close>
      by metis \<comment> \<open>Unfortunately, the simplifier cannot cope with arbitrarily
        directed equations, so we have to use some more powerful tool\<close>
  next
    case (Cons x l)
    show ?case
      apply clarsimp

      apply (subgoal_tac "na=n")

      txt \<open>The \<open>prec_frame\<close> and \<open>prec_frame'\<close> rules are
        useful to do precision proofs\<close>
      apply (erule prec_frame'[OF Cons.hyps])
      apply frame_inference
      apply frame_inference

      apply (drule prec_frame[OF sngr_prec])
      apply frame_inference
      apply frame_inference
      apply simp
      done
  qed
end


(*
   Title: Psi-calculi
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Subst_Term
  imports Chain
begin

locale substType =
  fixes subst :: "'a::fs_name \<Rightarrow> name list \<Rightarrow> 'b::fs_name list \<Rightarrow> 'a" ("_[_::=_]" [80, 80 ,80] 130)

  assumes eq[eqvt]: "\<And>p::name prm. (p \<bullet> (M[xvec::=Tvec])) = ((p \<bullet> M)[(p \<bullet> xvec)::=(p \<bullet> Tvec)])"
(*  and subst1:       "\<And>xvec Tvec T x. \<lbrakk>length xvec = length Tvec; distinct xvec; (x::name) \<sharp> T[xvec::=Tvec]; x \<sharp> xvec\<rbrakk> \<Longrightarrow> x \<sharp> T"
  and subst2:       "\<And>xvec Tvec T x. \<lbrakk>length xvec = length Tvec; distinct xvec; (x::name) \<sharp> T; x \<sharp> Tvec\<rbrakk> \<Longrightarrow> x \<sharp> T[xvec::=Tvec]"*)
  and subst3:       "\<And>xvec Tvec T x. \<lbrakk>length xvec = length Tvec; distinct xvec; set(xvec) \<subseteq> supp(T); (x::name) \<sharp> T[xvec::=Tvec]\<rbrakk> \<Longrightarrow> x \<sharp> Tvec"
(*  and subst4:       "\<And>xvec Tvec T. \<lbrakk>length xvec = length Tvec; distinct xvec; xvec \<sharp>* T\<rbrakk> \<Longrightarrow> T[xvec::=Tvec] = T"
  and subst5:       "\<And>xvec Tvec yvec Tvec' T. \<lbrakk>length xvec = length Tvec; distinct xvec; length yvec = length Tvec'; distinct yvec; yvec \<sharp>* xvec; yvec \<sharp>* Tvec\<rbrakk> \<Longrightarrow>
                                                T[(xvec@yvec)::=(Tvec@Tvec')] = (T[xvec::=Tvec])[yvec::=Tvec']"*)
  and renaming:     "\<And>xvec Tvec p T. \<lbrakk>length xvec = length Tvec; (set p) \<subseteq> set xvec \<times> set (p \<bullet> xvec);
                                      distinctPerm p; (p \<bullet> xvec) \<sharp>* T\<rbrakk> \<Longrightarrow>
                                      T[xvec::=Tvec] = (p \<bullet> T)[(p \<bullet> xvec)::=Tvec]"
begin

lemma suppSubst:
  fixes M    :: 'a
  and   xvec :: "name list"
  and   Tvec :: "'b list"

  shows "(supp(M[xvec::=Tvec])::name set) \<subseteq> ((supp M) \<union> (supp xvec) \<union> (supp Tvec))"
proof(auto simp add: eqvts supp_def)
  fix x::name
  let ?P = "\<lambda>y. ([(x, y)] \<bullet> M)[([(x, y)] \<bullet> xvec)::=([(x, y)] \<bullet> Tvec)] \<noteq> M[xvec::=Tvec]"
  let ?Q = "\<lambda>y M. ([(x, y)] \<bullet> M) \<noteq> (M::'a)"
  let ?R = "\<lambda>y xvec. ([(x, y)] \<bullet> xvec) \<noteq> (xvec::name list)"
  let ?S = "\<lambda>y Tvec. ([(x, y)] \<bullet> Tvec) \<noteq> (Tvec::'b list)"
  assume A: "finite {y. ?Q y M}" and B: "finite {y. ?R y xvec}" and C: "finite {y. ?S y Tvec}" and D: "infinite {y. ?P(y)}"
  hence "infinite({y. ?P(y)} - {y. ?Q y M}  - {y. ?R y xvec}  - {y. ?S y Tvec})"
    by(auto intro: Diff_infinite_finite)
  hence "infinite({y. ?P(y) \<and> \<not>(?Q y M) \<and> \<not> (?R y xvec) \<and> \<not> (?S y Tvec)})" by(simp add: set_diff_eq)
  moreover have "{y. ?P(y) \<and> \<not>(?Q y M) \<and> \<not> (?R y xvec) \<and> \<not> (?S y Tvec)} = {}" by auto
  ultimately have "infinite {}" by(drule_tac Infinite_cong) auto
  thus False by simp
qed

lemma subst2[intro]:
  fixes x    :: name
  and   M    :: 'a
  and   xvec :: "name list"
  and   Tvec :: "'b list"

  assumes "x \<sharp> M"
  and     "x \<sharp> xvec"
  and     "x \<sharp> Tvec"

  shows "x \<sharp> M[xvec::=Tvec]"
using assms suppSubst
by(auto simp add: fresh_def)

lemma subst2Chain[intro]:
  fixes yvec :: "name list"
  and   M    :: 'a
  and   xvec :: "name list"
  and   Tvec :: "'b list"

  assumes "yvec \<sharp>* M"
  and     "yvec \<sharp>* xvec"
  and     "yvec \<sharp>* Tvec"

  shows "yvec \<sharp>* M[xvec::=Tvec]"
using assms
by(induct yvec) auto

lemma fs[simp]: "finite ((supp subst)::name set)"
by(simp add: supp_def perm_fun_def eqvts)
(*
lemma subst1Chain:
  fixes xvec :: "name list"
  and   Tvec :: "'b list"
  and   Xs   :: "name set"
  and   T    :: 'a

  assumes "length xvec = length Tvec"
  and     "distinct xvec"
  and     "Xs \<sharp>* T[xvec::=Tvec]"
  and     "Xs \<sharp>* xvec"

  shows "Xs \<sharp>* T"
using assms
by(auto intro: subst1 simp add: fresh_star_def)
*)
lemma subst3Chain:
  fixes xvec :: "name list"
  and   Tvec :: "'b list"
  and   Xs   :: "name set"
  and   T    :: 'a

  assumes "length xvec = length Tvec"
  and     "distinct xvec"
  and     "set xvec \<subseteq> supp T"
  and     "Xs \<sharp>* T[xvec::=Tvec]"

  shows "Xs \<sharp>* Tvec"
using assms
by(auto intro: subst3 simp add: fresh_star_def)

lemma subst4Chain:
  fixes xvec :: "name list"
  and   Tvec :: "'b list"
  and   T    :: 'a

  assumes "length xvec = length Tvec"
  and     "distinct xvec"
  and     "xvec \<sharp>* Tvec"

  shows "xvec \<sharp>* T[xvec::=Tvec]"
proof -
  obtain p where "((p::name prm) \<bullet> (xvec::name list)) \<sharp>* T" and "(p \<bullet> xvec) \<sharp>* xvec"
             and S: "(set p) \<subseteq> set xvec \<times> set (p \<bullet> xvec)"
             and "distinctPerm p"
    by(rule_tac xvec=xvec and c="(T, xvec)" in name_list_avoiding) auto

  from \<open>length xvec = length Tvec\<close> have "length(p \<bullet> xvec) = length Tvec" by simp
  moreover from \<open>(p \<bullet> xvec) \<sharp>* T\<close> have "(p \<bullet> p \<bullet> xvec) \<sharp>* (p \<bullet> T)"
    by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
  with \<open>distinctPerm p\<close> have "xvec \<sharp>* (p \<bullet> T)" by simp
  ultimately have "(set xvec) \<sharp>* (p \<bullet> T)[(p \<bullet> xvec)::=Tvec]" using \<open>xvec \<sharp>* Tvec\<close> \<open>(p \<bullet> xvec) \<sharp>* xvec\<close>
    by auto

  thus ?thesis using \<open>length xvec = length Tvec\<close> \<open>distinct xvec\<close> S \<open>(p \<bullet> xvec) \<sharp>* T\<close> \<open>distinctPerm p\<close>
    by(simp add: renaming)
qed

definition seqSubst :: "'a \<Rightarrow> (name list \<times> 'b list) list \<Rightarrow> 'a" ("_[<_>]" [80, 80] 130)
  where "M[<\<sigma>>] \<equiv> foldl (\<lambda>N. \<lambda>(xvec, Tvec). N[xvec::=Tvec]) M \<sigma>"

lemma seqSubstNil[simp]:
  "seqSubst M [] = M"
by(simp add: seqSubst_def)

lemma seqSubstCons[simp]:
  shows "seqSubst M ((xvec, Tvec)#\<sigma>) = seqSubst(M[xvec::=Tvec]) \<sigma>"
  by(simp add: seqSubst_def)

lemma seqSubstTermAppend[simp]:
  shows "seqSubst M (\<sigma>@\<sigma>') = seqSubst (seqSubst M \<sigma>) \<sigma>'"
by(induct \<sigma>) (auto simp add: seqSubst_def)

definition wellFormedSubst :: "(('d::fs_name) list \<times> ('e::fs_name) list) list \<Rightarrow> bool" where "wellFormedSubst \<sigma> = ((filter (\<lambda>(xvec, Tvec). \<not>(length xvec = length Tvec \<and> distinct xvec)) \<sigma>) = [])"

lemma wellFormedSubstEqvt[eqvt]:
  fixes \<sigma> :: "(('d::fs_name) list \<times> ('e::fs_name) list) list"
  and   p :: "name prm"

  shows "p \<bullet> (wellFormedSubst \<sigma>) = wellFormedSubst(p \<bullet> \<sigma>)"
by(induct \<sigma> arbitrary: p) (auto simp add: eqvts wellFormedSubst_def)

lemma wellFormedSimp[simp]:
  fixes \<sigma> :: "(('d::fs_name) list \<times> ('e::fs_name) list) list"
  and   p :: "name prm"

  shows "wellFormedSubst(p \<bullet> \<sigma>) = wellFormedSubst \<sigma>"
by(induct \<sigma>) (auto simp add: eqvts wellFormedSubst_def)

lemma wellFormedNil[simp]:
  "wellFormedSubst []"
by(simp add: wellFormedSubst_def)

lemma wellFormedCons[simp]:
  shows "wellFormedSubst((xvec, Tvec)#\<sigma>) = (length xvec = length Tvec \<and> distinct xvec \<and> wellFormedSubst \<sigma>)"
by(simp add: wellFormedSubst_def) auto

lemma wellFormedAppend[simp]:
  fixes \<sigma>  :: "(('d::fs_name) list \<times> ('e::fs_name) list) list"
  and   \<sigma>' :: "(('d::fs_name) list \<times> ('e::fs_name) list) list"

  shows "wellFormedSubst(\<sigma>@\<sigma>') = (wellFormedSubst \<sigma> \<and> wellFormedSubst \<sigma>')"
by(simp add: wellFormedSubst_def)

lemma seqSubst2[intro]:
  fixes \<sigma> :: "(name list \<times> 'b list) list"
  and   T :: 'a
  and   x :: name

  assumes "x \<sharp> \<sigma>"
  and     "x \<sharp> T"

  shows "x \<sharp> T[<\<sigma>>]"
using assms
by(induct \<sigma> arbitrary: T) (clarsimp |  blast)+

lemma seqSubst2Chain[intro]:
  fixes \<sigma>    :: "(name list \<times> 'b list) list"
  and   T    :: 'a
  and   xvec :: "name list"

  assumes "xvec \<sharp>* \<sigma>"
  and     "xvec \<sharp>* T"

  shows "xvec \<sharp>* T[<\<sigma>>]"
using assms
by(induct xvec) auto

end

end