(*
Title:KoenigsbergBridge.thy
Author:Wenda Li
*)

theory KoenigsbergBridge imports MoreGraph Map Enum
begin

section{*Definition of Eulerian trails and circuits*}

definition (in valid_unMultigraph) is_Eulerian_trail:: "'v\<Rightarrow>('v,'w) path\<Rightarrow>'v\<Rightarrow> bool" where
  "is_Eulerian_trail v ps v'\<equiv> is_trail v ps v' \<and> edges (rem_unPath ps G) = {}"

definition (in valid_unMultigraph) is_Eulerian_circuit:: "'v \<Rightarrow> ('v,'w) path \<Rightarrow> 'v \<Rightarrow> bool" where
  "is_Eulerian_circuit v ps v'\<equiv> (v=v') \<and> (is_Eulerian_trail v ps v')"

section{*Necessary conditions for Eulerian trails and circuits*}

lemma (in valid_unMultigraph) euclerian_rev:
  "is_Eulerian_trail v' (rev_path ps) v=is_Eulerian_trail v ps v' "
proof -
  have "is_trail v' (rev_path ps) v=is_trail v ps v'"
    by (metis is_trail_rev)
  moreover have "edges (rem_unPath (rev_path ps) G)=edges (rem_unPath ps G)"
    by (metis rem_unPath_graph)
  ultimately show ?thesis unfolding is_Eulerian_trail_def by auto
qed

(*Necessary conditions for Eulerian circuits*)
theorem (in valid_unMultigraph) euclerian_cycle_ex:
  assumes "is_Eulerian_circuit v ps v'" "finite V" "finite E"
  shows "\<forall>v\<in>V. even (degree v G)"
proof -
  obtain v ps v' where cycle:"is_Eulerian_circuit v ps v'" using assms by auto
  hence "edges (rem_unPath ps G) = {}"
    unfolding is_Eulerian_circuit_def is_Eulerian_trail_def
    by simp
  moreover have "nodes (rem_unPath ps G)=nodes G" by auto
  ultimately have "rem_unPath ps G = G \<lparr>edges:={}\<rparr>" by auto
  hence "num_of_odd_nodes (rem_unPath ps G) = 0" by (metis assms(2) odd_nodes_no_edge)
  moreover have "v=v'"
    by (metis `is_Eulerian_circuit v ps v'` is_Eulerian_circuit_def)
  hence "num_of_odd_nodes (rem_unPath ps G)=num_of_odd_nodes G"
    by (metis assms(2) assms(3) cycle is_Eulerian_circuit_def
        is_Eulerian_trail_def rem_UnPath_cycle)
  ultimately have "num_of_odd_nodes G=0" by auto
  moreover have "finite(odd_nodes_set G)"
    using `finite V` unfolding odd_nodes_set_def by auto
  ultimately have "odd_nodes_set G = {}" unfolding num_of_odd_nodes_def by auto
  thus ?thesis unfolding odd_nodes_set_def by auto
qed

(*Necessary conditions for Eulerian trails*)
theorem (in valid_unMultigraph) euclerian_path_ex:
  assumes "is_Eulerian_trail v ps v'" "finite V" "finite E"
  shows "(\<forall>v\<in>V. even (degree v G)) \<or> (num_of_odd_nodes G =2)"
proof -
  obtain v ps v' where path:"is_Eulerian_trail v ps v'" using assms by auto
  hence "edges (rem_unPath ps G) = {}"
    unfolding  is_Eulerian_trail_def
    by simp
  moreover have "nodes (rem_unPath ps G)=nodes G" by auto
  ultimately have "rem_unPath ps G = G \<lparr>edges:={}\<rparr>" by auto
  hence odd_nodes: "num_of_odd_nodes (rem_unPath ps G) = 0"
    by (metis assms(2) odd_nodes_no_edge)
  have "v\<noteq>v' \<Longrightarrow> ?thesis"
    proof (cases "even(degree v' G)")
      case True
      assume "v\<noteq>v'"
      have "is_trail v ps v'" by (metis is_Eulerian_trail_def path)
      hence "num_of_odd_nodes (rem_unPath ps G) = num_of_odd_nodes G
          + (if even (degree v G) then 2 else 0)"
        using rem_UnPath_even True `finite V` `finite E` `v\<noteq>v'` by auto
      hence "num_of_odd_nodes G + (if even (degree v G) then 2 else 0)=0"
        using odd_nodes by auto
      hence "num_of_odd_nodes G = 0" by auto
      moreover have "finite(odd_nodes_set G)"
        using `finite V` unfolding odd_nodes_set_def by auto
      ultimately have "odd_nodes_set G = {}" unfolding num_of_odd_nodes_def by auto
      thus ?thesis unfolding odd_nodes_set_def by auto
    next
      case False
      assume "v\<noteq>v'"
      have "is_trail v ps v'" by (metis is_Eulerian_trail_def path)
      hence "num_of_odd_nodes (rem_unPath ps G) = num_of_odd_nodes G
          + (if odd (degree v G) then -2 else 0)"
        using rem_UnPath_odd False `finite V` `finite E` `v\<noteq>v'` by auto
      hence odd_nodes_if: "num_of_odd_nodes G + (if odd (degree v G) then -2 else 0)=0"
        using odd_nodes by auto
      have "odd (degree v G) \<Longrightarrow> ?thesis"
        proof -
          assume "odd (degree v G)"
          hence "num_of_odd_nodes G = 2" using odd_nodes_if by auto
          thus ?thesis by simp
        qed
      moreover have "even(degree v G) \<Longrightarrow> ?thesis"
        proof -
          assume "even (degree v G)"
          hence "num_of_odd_nodes G = 0" using odd_nodes_if by auto
          moreover have "finite(odd_nodes_set G)"
            using `finite V` unfolding odd_nodes_set_def by auto
          ultimately have "odd_nodes_set G = {}" unfolding num_of_odd_nodes_def by auto
          thus ?thesis unfolding odd_nodes_set_def by auto
        qed
      ultimately show ?thesis by auto
    qed
  moreover have "v=v'\<Longrightarrow> ?thesis"
    by (metis assms(2) assms(3) euclerian_cycle_ex is_Eulerian_circuit_def path)
  ultimately show ?thesis by auto
qed

section{*Specific case of the Konigsberg Bridge Problem*}

(*to denote the four landmasses*)
datatype kon_node = a | b | c | d

(*to denote the seven bridges*)
datatype kon_bridge = ab1 | ab2 | ac1 | ac2 | ad1 | bd1 | cd1

definition kon_graph :: "(kon_node,kon_bridge) graph" where
  "kon_graph\<equiv>\<lparr>nodes={a,b,c,d},
              edges={(a,ab1,b), (b,ab1,a),
                     (a,ab2,b), (b,ab2,a),
                     (a,ac1,c), (c,ac1,a),
                     (a,ac2,c), (c,ac2,a),
                     (a,ad1,d), (d,ad1,a),
                     (b,bd1,d), (d,bd1,b),
                     (c,cd1,d), (d,cd1,c)} \<rparr>"

instantiation kon_node :: enum
begin
definition [simp]:  "enum_class.enum =[a,b,c,d]"
definition  [simp]: "enum_class.enum_all P \<longleftrightarrow> P a \<and> P b \<and> P c \<and> P d"
definition   [simp]:"enum_class.enum_ex P \<longleftrightarrow> P a \<or> P b \<or> P c \<or> P d"
instance proof qed (auto,(case_tac x,auto)+)
end

instantiation kon_bridge :: enum
begin
definition [simp]:"enum_class.enum =[ab1,ab2,ac1,ac2,ad1,cd1,bd1]"
definition  [simp]:"enum_class.enum_all P \<longleftrightarrow> P ab1 \<and> P ab2 \<and> P ac1 \<and> P ac2 \<and> P ad1  \<and> P bd1
    \<and> P cd1"
definition   [simp]:"enum_class.enum_ex P \<longleftrightarrow>  P ab1 \<or> P ab2 \<or> P ac1 \<or> P ac2 \<or> P ad1  \<or> P bd1
    \<or> P cd1"
instance proof qed (auto,(case_tac x,auto)+)
end

interpretation   kon_graph: valid_unMultigraph kon_graph
proof (unfold_locales)
  show "fst ` edges kon_graph \<subseteq> nodes kon_graph" by eval
next
  show "snd ` snd ` edges kon_graph \<subseteq> nodes kon_graph"  by eval
next
  have " \<forall>v w u'. ((v, w, u') \<in> edges kon_graph) = ((u', w, v) \<in> edges kon_graph)"
    by eval
  thus "\<And>v w u'. ((v, w, u') \<in> edges kon_graph) = ((u', w, v) \<in> edges kon_graph)" by simp
next
  have "\<forall>v w. (v, w, v) \<notin> edges kon_graph"  by eval
  thus "\<And>v w. (v, w, v) \<notin> edges kon_graph" by simp
qed

(*The specific case of the Konigsberg Bridge Problem does not have a solution*)
theorem "\<not>kon_graph.is_Eulerian_trail v1 p v2"
proof
  assume "kon_graph.is_Eulerian_trail  v1 p v2"
  moreover have "finite (nodes kon_graph)" by (metis finite_code)
  moreover have "finite (edges kon_graph)" by (metis finite_code)
  ultimately have contra:
    "(\<forall>v\<in>nodes kon_graph. even (degree v kon_graph)) \<or>(num_of_odd_nodes kon_graph =2)"
    by (metis kon_graph.euclerian_path_ex)
  have "odd(degree a kon_graph)" by eval
  moreover have "odd(degree b kon_graph)" by eval
  moreover have "odd(degree c kon_graph)" by eval
  moreover have "odd(degree d kon_graph)" by eval
  ultimately have "\<not>(num_of_odd_nodes kon_graph =2)" by eval
  moreover have "\<not>(\<forall>v\<in>nodes kon_graph. even (degree v kon_graph))" by eval
  ultimately show False using contra by auto
qed

section{*Sufficient conditions for Eulerian trails and circuits*}

lemma (in valid_unMultigraph) eulerian_cons:
  assumes
    "valid_unMultigraph.is_Eulerian_trail (del_unEdge v0 w v1 G) v1 ps v2"
    "(v0,w,v1)\<in> E"
  shows "is_Eulerian_trail v0 ((v0,w,v1)#ps) v2"
proof -
  have valid:"valid_unMultigraph (del_unEdge v0 w v1 G)"
    using  valid_unMultigraph_axioms by auto
  hence distinct:"valid_unMultigraph.is_trail (del_unEdge v0 w v1 G) v1 ps v2"
    using assms unfolding valid_unMultigraph.is_Eulerian_trail_def[OF valid]
    by auto
  hence "set ps \<subseteq> edges (del_unEdge v0 w v1 G)"
    using valid_unMultigraph.path_in_edges[OF valid] by auto
  moreover have "(v0,w,v1)\<notin>edges (del_unEdge v0 w v1 G)"
    unfolding del_unEdge_def by auto
  moreover have "(v1,w,v0)\<notin>edges (del_unEdge v0 w v1 G)"
    unfolding del_unEdge_def by auto
  ultimately have "(v0,w,v1)\<notin>set ps" "(v1,w,v0)\<notin>set ps"  by auto
  moreover have "is_trail v1 ps v2"
    using distinct_path_intro[OF distinct] .
  ultimately have "is_trail v0 ((v0,w,v1)#ps) v2"
    using `(v0,w,v1)\<in> E` by auto
  moreover have "edges (rem_unPath ps (del_unEdge v0 w v1 G)) ={}"
    using assms unfolding valid_unMultigraph.is_Eulerian_trail_def[OF valid]
    by auto
  hence "edges (rem_unPath ((v0,w,v1)#ps) G)={}"
    by (metis rem_unPath.simps(2))
  ultimately show ?thesis unfolding is_Eulerian_trail_def by auto
qed

lemma (in valid_unMultigraph) eulerian_cons':
  assumes
    "valid_unMultigraph.is_Eulerian_trail (del_unEdge v2 w v3 G) v1 ps v2"
    "(v2,w,v3)\<in> E"
  shows "is_Eulerian_trail v1 (ps@[(v2,w,v3)]) v3"
proof -
  have valid:"valid_unMultigraph (del_unEdge v3 w v2 G)"
    using valid_unMultigraph_axioms del_unEdge_valid by auto
  have "del_unEdge v2 w v3 G=del_unEdge v3 w v2 G"
    by (metis delete_edge_sym)
  hence "valid_unMultigraph.is_Eulerian_trail (del_unEdge v3 w v2 G) v2
        (rev_path ps) v1" using assms valid_unMultigraph.euclerian_rev[OF valid]
    by auto
  hence "is_Eulerian_trail v3 ((v3,w,v2)#(rev_path ps)) v1"
    using eulerian_cons by (metis assms(2) corres)
  hence "is_Eulerian_trail v1 (rev_path((v3,w,v2)#(rev_path ps))) v3"
    using euclerian_rev by auto
  moreover have "rev_path((v3,w,v2)#(rev_path ps)) = rev_path(rev_path ps)@[(v2,w,v3)]"
    unfolding rev_path_def by auto
  hence "rev_path((v3,w,v2)#(rev_path ps))=ps@[(v2,w,v3)]" by auto
  ultimately show ?thesis by auto
qed

lemma eulerian_split:
  assumes "nodes G1 \<inter> nodes G2 = {}" "edges G1 \<inter> edges G2={}"
    "valid_unMultigraph G1" "valid_unMultigraph G2"
    "valid_unMultigraph.is_Eulerian_trail  G1 v1 ps1 v1'"
    "valid_unMultigraph.is_Eulerian_trail  G2 v2 ps2 v2'"
  shows "valid_unMultigraph.is_Eulerian_trail \<lparr>nodes=nodes G1 \<union> nodes G2,
          edges=edges G1 \<union> edges G2 \<union> {(v1',w,v2),(v2,w,v1')}\<rparr> v1 (ps1@(v1',w,v2)#ps2) v2'"
proof -
  have "valid_graph G1" using `valid_unMultigraph G1` valid_unMultigraph_def by auto
  have "valid_graph G2" using `valid_unMultigraph G2` valid_unMultigraph_def by auto
  obtain G where G:"G=\<lparr>nodes=nodes G1 \<union> nodes G2, edges=edges G1 \<union> edges G2
      \<union> {(v1',w,v2),(v2,w,v1')}\<rparr>"
    by metis
  have "v1'\<in>nodes G1"
    by (metis (full_types) `valid_graph G1` assms(3) assms(5) valid_graph.is_path_memb
        valid_unMultigraph.is_trail_intro valid_unMultigraph.is_Eulerian_trail_def)
  moreover have "v2\<in>nodes G2"
    by (metis (full_types) `valid_graph G2` assms(4) assms(6) valid_graph.is_path_memb
        valid_unMultigraph.is_trail_intro valid_unMultigraph.is_Eulerian_trail_def)
  ultimately have "valid_unMultigraph \<lparr>nodes=nodes G1 \<union> nodes G2, edges=edges G1 \<union> edges G2 \<union>
                   {(v1',w,v2),(v2,w,v1')}\<rparr>"
    using
      valid_unMultigraph.corres[OF `valid_unMultigraph G1`]
      valid_unMultigraph.no_id[OF `valid_unMultigraph G1`]
      valid_unMultigraph.corres[OF `valid_unMultigraph G2`]
      valid_unMultigraph.no_id[OF `valid_unMultigraph G2`]
      valid_graph.E_validD[OF `valid_graph G1`]
      valid_graph.E_validD[OF `valid_graph G2`]
      `nodes G1 \<inter> nodes G2 = {}`
    proof (unfold_locales,auto)
      fix aa ab ba
      assume  "(aa, ab, ba) \<in> edges G1"
      thus "ba \<in> nodes G1" by (metis `\<And>v' v e. (v, e, v') \<in> edges G1 \<Longrightarrow> v' \<in> nodes G1`)
    next
      fix aa ab ba
      assume "ba \<notin> nodes G2"  "(aa, ab, ba) \<in> edges G2"
      thus "ba \<in> nodes G1" by (metis `valid_graph G2` valid_graph.E_validD(2))
    qed
  hence valid: "valid_unMultigraph G" using G by auto
  hence valid':"valid_graph G" using valid_unMultigraph_def by auto
  moreover have "valid_unMultigraph.is_trail G v1 (ps1@((v1',w,v2)#ps2)) v2'"
    proof -
      have ps1_G:"valid_unMultigraph.is_trail G v1 ps1 v1'"
        proof -
          have "valid_unMultigraph.is_trail G1 v1 ps1 v1'" using assms
            by (metis valid_unMultigraph.is_Eulerian_trail_def)
          moreover have "edges G1 \<subseteq> edges G" by (metis G UnI1 Un_assoc select_convs(2) subrelI)
          moreover have "nodes G1 \<subseteq> nodes G" by (metis G inf_sup_absorb le_iff_inf select_convs(1))
          ultimately show ?thesis
            using distinct_path_subset[of G1 G,OF `valid_unMultigraph G1` valid] by auto
        qed
      have ps2_G:"valid_unMultigraph.is_trail G v2 ps2 v2'"
        proof -
          have "valid_unMultigraph.is_trail G2 v2 ps2 v2'" using assms
            by (metis valid_unMultigraph.is_Eulerian_trail_def)
          moreover have "edges G2 \<subseteq> edges G" by (metis G inf_sup_ord(3) le_supE select_convs(2))
          moreover have "nodes G2 \<subseteq> nodes G" by (metis G inf_sup_ord(4) select_convs(1))
          ultimately show ?thesis
            using distinct_path_subset[of G2 G,OF `valid_unMultigraph G2` valid] by auto
        qed
      have "valid_graph.is_path G v1 (ps1@((v1',w,v2)#ps2)) v2'"
        proof -
          have "valid_graph.is_path  G v1 ps1 v1'"
            by (metis ps1_G valid valid_unMultigraph.is_trail_intro)
          moreover have "valid_graph.is_path G v2 ps2 v2'"
            by (metis ps2_G valid valid_unMultigraph.is_trail_intro)
          moreover have "(v1',w,v2) \<in> edges G"
            using G by auto
          ultimately show ?thesis
            using valid_graph.is_path_split'[OF valid',of v1 ps1 v1' w v2 ps2 v2'] by auto
        qed
      moreover have "distinct (ps1@((v1',w,v2)#ps2))"
        proof -
          have "distinct ps1" by (metis ps1_G valid valid_unMultigraph.is_trail_path)
          moreover have "distinct ps2"
            by (metis ps2_G valid valid_unMultigraph.is_trail_path)
          moreover have "set ps1 \<inter> set ps2 = {}"
            proof -
              have "set ps1 \<subseteq>edges G1"
                by (metis assms(3) assms(5) valid_unMultigraph.is_Eulerian_trail_def
                    valid_unMultigraph.path_in_edges)
              moreover have "set ps2 \<subseteq> edges G2"
                by (metis assms(4) assms(6) valid_unMultigraph.is_Eulerian_trail_def
                    valid_unMultigraph.path_in_edges)
              ultimately show ?thesis using `edges G1 \<inter> edges G2={}` by auto
            qed
          moreover have "(v1',w,v2)\<notin>edges G1"
            using `v2 \<in> nodes G2` `valid_graph G1`
            by (metis Int_iff  all_not_in_conv assms(1) valid_graph.E_validD(2))
          hence "(v1',w,v2)\<notin>set ps1"
            by (metis (full_types) assms(3) assms(5) subsetD valid_unMultigraph.path_in_edges
                valid_unMultigraph.is_Eulerian_trail_def )
          moreover have "(v1',w,v2)\<notin>edges G2"
            using `v1' \<in> nodes G1` `valid_graph G2`
            by (metis  assms(1) disjoint_iff_not_equal valid_graph.E_validD(1))
          hence  "(v1',w,v2)\<notin>set ps2"
            by (metis (full_types)  assms(4) assms(6) in_mono valid_unMultigraph.path_in_edges
                valid_unMultigraph.is_Eulerian_trail_def )
          ultimately show ?thesis using distinct_append by auto
        qed
      moreover have "set (ps1@((v1',w,v2)#ps2)) \<inter> set (rev_path (ps1@((v1',w,v2)#ps2))) = {}"
        proof -
          have "set ps1 \<inter> set (rev_path ps1) = {}"
            by (metis ps1_G valid valid_unMultigraph.is_trail_path)
          moreover have "set (rev_path ps2) \<subseteq> edges G2"
            by (metis assms(4) assms(6) valid_unMultigraph.is_trail_rev
                valid_unMultigraph.is_Eulerian_trail_def valid_unMultigraph.path_in_edges)
          hence "set ps1 \<inter> set (rev_path ps2) = {}"
            using assms
              valid_unMultigraph.path_in_edges[OF `valid_unMultigraph G1`, of v1 ps1 v1']
              valid_unMultigraph.path_in_edges[OF `valid_unMultigraph G2`, of v2 ps2 v2']
            unfolding valid_unMultigraph.is_Eulerian_trail_def[OF `valid_unMultigraph G1`]
              valid_unMultigraph.is_Eulerian_trail_def[OF `valid_unMultigraph G2`]
            by auto
          moreover have "set ps2 \<inter> set (rev_path ps2) = {}"
            by (metis ps2_G valid valid_unMultigraph.is_trail_path)
          moreover have "set (rev_path ps1) \<subseteq>edges G1"
            by (metis assms(3) assms(5) valid_unMultigraph.is_Eulerian_trail_def
                valid_unMultigraph.path_in_edges valid_unMultigraph.euclerian_rev)
          hence "set ps2 \<inter> set (rev_path ps1) = {}"
            by (metis calculation(2) distinct_append distinct_rev_path ps1_G ps2_G rev_path_append
              rev_path_double valid valid_unMultigraph.is_trail_path)
          moreover have "(v2,w,v1')\<notin>set (ps1@((v1',w,v2)#ps2))"
            proof -
              have "(v2,w,v1')\<notin>edges G1"
                using `v2 \<in> nodes G2` `valid_graph G1`
                by (metis Int_iff  all_not_in_conv assms(1) valid_graph.E_validD(1))
              hence "(v2,w,v1')\<notin>set ps1"
                by (metis assms(3) assms(5) split_list valid_unMultigraph.is_trail_split'
                    valid_unMultigraph.is_Eulerian_trail_def)
              moreover have "(v2,w,v1')\<notin>edges G2"
                using `v1' \<in> nodes G1` `valid_graph G2`
                by (metis IntI assms(1) empty_iff valid_graph.E_validD(2))
              hence "(v2,w,v1')\<notin>set ps2"
                by (metis (full_types) assms(4) assms(6) in_mono  valid_unMultigraph.path_in_edges
                    valid_unMultigraph.is_Eulerian_trail_def)
              moreover have "(v2,w,v1')\<noteq>(v1',w,v2)"
                using `v1' \<in> nodes G1` `v2 \<in> nodes G2`
                by (metis IntI Pair_inject  assms(1) assms(5) bex_empty)
              ultimately show ?thesis by auto
            qed
          ultimately show ?thesis using rev_path_append by auto
        qed
      ultimately show ?thesis using valid_unMultigraph.is_trail_path[OF valid]
        by auto
    qed
  moreover have "edges (rem_unPath (ps1@((v1',w,v2)#ps2)) G)= {}"
    proof -
      have "edges (rem_unPath (ps1@((v1',w,v2)#ps2)) G)=edges G -
           (set (ps1@((v1',w,v2)#ps2)) \<union> set (rev_path (ps1@((v1',w,v2)#ps2))))"
        by (metis rem_unPath_edges)
      also have "...=edges G - (set ps1 \<union> set ps2 \<union> set (rev_path ps1) \<union> set (rev_path ps2)
                 \<union> {(v1',w,v2),(v2,w,v1')})" using rev_path_append by auto
      finally have "edges (rem_unPath (ps1@((v1',w,v2)#ps2)) G) = edges G - (set ps1 \<union>
                    set ps2 \<union> set (rev_path ps1) \<union> set (rev_path ps2) \<union> {(v1',w,v2),(v2,w,v1')})" .
      moreover have "edges (rem_unPath ps1 G1)={}"
        by (metis assms(3) assms(5) valid_unMultigraph.is_Eulerian_trail_def)
      hence "edges G1 - (set ps1 \<union> set (rev_path ps1))={}"
        by (metis rem_unPath_edges)
      moreover have "edges (rem_unPath ps2 G2)={}"
        by (metis assms(4) assms(6) valid_unMultigraph.is_Eulerian_trail_def)
      hence "edges G2 - (set ps2 \<union> set (rev_path ps2))={}"
        by (metis rem_unPath_edges)
      ultimately show ?thesis using G by auto
    qed
  ultimately show ?thesis by (metis G valid valid_unMultigraph.is_Eulerian_trail_def)
qed


theory BExp imports AExp begin

subsection "Boolean Expressions"

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

text_raw{*\snip{BExpbvaldef}{1}{2}{% *}
fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc v) s = v" |
"bval (Not b) s = (\<not> bval b s)" |
"bval (And b\<^sub>1 b\<^sub>2) s = (bval b\<^sub>1 s \<and> bval b\<^sub>2 s)" |
"bval (Less a\<^sub>1 a\<^sub>2) s = (aval a\<^sub>1 s < aval a\<^sub>2 s)"
text_raw{*}%endsnip*}

value "bval (Less (V ''x'') (Plus (N 3) (V ''y'')))
            <''x'' := 3, ''y'' := 1>"

text{* To improve automation: *}

lemma bval_And_if[simp]:
  "bval (And b1 b2) s = (if bval b1 s then bval b2 s else False)"
by(simp)

declare bval.simps(3)[simp del]  --"remove the original eqn"

subsection "Constant Folding"

text{* Optimizing constructors: *}

text_raw{*\snip{BExplessdef}{0}{2}{% *}
fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"less (N n\<^sub>1) (N n\<^sub>2) = Bc(n\<^sub>1 < n\<^sub>2)" |
"less a\<^sub>1 a\<^sub>2 = Less a\<^sub>1 a\<^sub>2"
text_raw{*}%endsnip*}

text_raw{*\snip{BExpanddef}{2}{2}{% *}
fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"and (Bc True) b = b" |
"and b (Bc True) = b" |
"and (Bc False) b = Bc False" |
"and b (Bc False) = Bc False" |
"and b\<^sub>1 b\<^sub>2 = And b\<^sub>1 b\<^sub>2"
text_raw{*}%endsnip*}

lemma bval_and[simp]: "bval (and b1 b2) s = (bval b1 s \<and> bval b2 s)"
apply(induction b1 b2 rule: and.induct)
apply simp_all
done

text_raw{*\snip{BExpnotdef}{2}{2}{% *}
fun not :: "bexp \<Rightarrow> bexp" where
"not (Bc True) = Bc False" |
"not (Bc False) = Bc True" |
"not b = Not b"
text_raw{*}%endsnip*}

lemma bval_not[simp]: "bval (not b) s = (\<not> bval b s)"
apply(induction b rule: not.induct)
apply simp_all
done

text{* Now the overall optimizer: *}

text_raw{*\snip{BExpbsimpdef}{0}{2}{% *}
fun bsimp :: "bexp \<Rightarrow> bexp" where
"bsimp (Bc v) = Bc v" |
"bsimp (Not b) = not(bsimp b)" |
"bsimp (And b\<^sub>1 b\<^sub>2) = and (bsimp b\<^sub>1) (bsimp b\<^sub>2)" |
"bsimp (Less a\<^sub>1 a\<^sub>2) = less (asimp a\<^sub>1) (asimp a\<^sub>2)"
text_raw{*}%endsnip*}

value "bsimp (And (Less (N 0) (N 1)) b)"

value "bsimp (And (Less (N 1) (N 0)) (Bc True))"

theorem "bval (bsimp b) s = bval b s"
apply(induction b)
apply simp_all
done

end


chapter "Arithmetic and Boolean Expressions"

theory Chapter3_ex3_04_AExp imports Main begin

subsection "Arithmetic Expressions"

type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

text_raw{*\snip{AExpaexpdef}{2}{1}{% *}
datatype aexp =
    N int
  | V vname
  | Plus aexp aexp
  | Times aexp aexp
text_raw{*}%endsnip*}

text_raw{*\snip{AExpavaldef}{1}{2}{% *}

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n)         s = n"                    |
"aval (V x)         s = s x"                  |
"aval (Plus a\<^sub>1 a\<^sub>2)  s = aval a\<^sub>1 s + aval a\<^sub>2 s" |
"aval (Times a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s * aval a\<^sub>2 s"

text_raw{*}%endsnip*}

value "aval (Plus (V ''x'') (N 5)) (\<lambda>x. if x = ''x'' then 7 else 0)"

text {* The same state more concisely: *}
value "aval (Plus (V ''x'') (N 5)) ((\<lambda>x. 0) (''x'':= 7))"

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

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"

text {* \noindent
  We can now write a series of updates to the function @{text "\<lambda>x. 0"} compactly:
*}
lemma "<a := Suc 0, b := 2> = (<> (a := Suc 0)) (b := 2)"
  by (rule refl)

value "aval (Plus (V ''x'') (N 5)) <''x'' := 7>"

text {* In  the @{term[source] "<a := b>"} syntax, variables that are not mentioned are 0 by default:
*}
value "aval (Plus (V ''x'') (N 5)) <''y'' := 7>"

text{* Note that this @{text"<\<dots>>"} syntax works for any function space
@{text"\<tau>\<^sub>1 \<Rightarrow> \<tau>\<^sub>2"} where @{text "\<tau>\<^sub>2"} has a @{text 0}. *}

subsection "Constant Folding"

text{* Evaluate constant subsexpressions: *}

text_raw{*\snip{AExpasimpconstdef}{0}{2}{% *}

fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V x) = V x" |
"asimp_const (Plus a\<^sub>1 a\<^sub>2) =
  (case (asimp_const a\<^sub>1, asimp_const a\<^sub>2) of
    (N n\<^sub>1, N n\<^sub>2) \<Rightarrow> N (n\<^sub>1 + n\<^sub>2) |
    (b\<^sub>1,   b\<^sub>2)   \<Rightarrow> Plus b\<^sub>1 b\<^sub>2)" |
"asimp_const (Times a\<^sub>1 a\<^sub>2) =
  (case (asimp_const a\<^sub>1, asimp_const a\<^sub>2) of
    (N n\<^sub>1, N n\<^sub>2) \<Rightarrow> N (n\<^sub>1 * n\<^sub>2) |
    (b\<^sub>1,   b\<^sub>2)   \<Rightarrow> Times b\<^sub>1 b\<^sub>2)"

text_raw{*}%endsnip*}

theorem aval_asimp_const:
  "aval (asimp_const a) s = aval a s"
apply(induction a)
apply (auto split: aexp.split)
done

text{* Now we also eliminate all occurrences 0 in additions. The standard
method: optimized versions of the constructors: *}

text_raw{*\snip{AExpplusdef}{0}{2}{% *}

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i\<^sub>1) (N i\<^sub>2) = N (i\<^sub>1 + i\<^sub>2)" |
"plus (N i)  a      = (if i = 0 then a else Plus (N i) a)" |
"plus a      (N i)  = (if i = 0 then a else Plus a (N i))" |
"plus a\<^sub>1     a\<^sub>2     = Plus a\<^sub>1 a\<^sub>2"

text_raw{*}%endsnip*}

text_raw{*\snip{AExpplusdef}{0}{2}{% *}

fun times :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"times (N i\<^sub>1) (N i\<^sub>2) = N (i\<^sub>1 * i\<^sub>2)" |
"times (N i)  a      = (if i = 1 then a else Times (N i) a)" |
"times a      (N i)  = (if i = 1 then a else Times a (N i))" |
"times a\<^sub>1     a\<^sub>2     = Times a\<^sub>1 a\<^sub>2"

text_raw{*}%endsnip*}

lemma aval_plus[simp]:
  "aval (plus a1 a2) s = aval a1 s + aval a2 s"
apply(induction a1 a2 rule: plus.induct)
apply simp_all (* just for a change from auto *)
done

lemma aval_times : "aval (times a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s * aval a\<^sub>2 s"
apply(induction a\<^sub>1 a\<^sub>2 rule: times.induct)
apply(auto)
done

text_raw{*\snip{AExpasimpdef}{2}{0}{% *}
fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n)        = N n"                        |
"asimp (V x)        = V x"                        |
"asimp (Plus a\<^sub>1 a\<^sub>2)  = plus (asimp a\<^sub>1) (asimp a\<^sub>2)" |
"asimp (Times a\<^sub>1 a\<^sub>2) = times (asimp a\<^sub>1) (asimp a\<^sub>2)"
text_raw{*}%endsnip*}

text{* Note that in @{const asimp_const} the optimized constructor was
inlined. Making it a separate function @{const plus} improves modularity of
the code and the proofs. *}

value "asimp (Plus (Plus (N 0) (N 0)) (Plus (V ''x'') (N 0)))"

theorem aval_asimp[simp]:
  "aval (asimp a) s = aval a s"
apply(induction a)
apply(simp_all add: aval_times)
done

end


theory CStruct
imports Main Sequences
begin

section {* A formalization of command ctructures (C-Structs)*}

text {* C-Structs were introduced by Leslie Lamport in \cite{Lamport05GeneralizeConsensus}
  for the definition of Generalized Consensus *}

subsection {* The pre-CStruct locale fixes constants and makes some definitions that
  are used in the C-Struct locale to state the properties of C-Structs.*}

locale pre_CStruct = Sequences +
  fixes \<delta>::"'a \<Rightarrow> 'c \<Rightarrow> 'a" (infix "\<bullet>" 65)
  and bot::'a ("\<bottom>")
begin

fun exec::"'a \<Rightarrow> 'c list \<Rightarrow> 'a" (infix "\<star>" 65) where
  "exec s Nil = s"
| "exec s (rs#r) = (exec s rs) \<bullet> r"

definition less_eq (infix "\<preceq>" 50) where
  "less_eq s s' \<equiv> \<exists> rs . s' = (s\<star>rs)"

definition less (infix "\<prec>" 50) where
  "less s s' \<equiv> less_eq s s' \<and> s \<noteq> s'"

definition is_lb where
  "is_lb s s1 s2 \<equiv> s \<preceq> s2 \<and> s \<preceq> s1"

definition is_ub where
  "is_ub s s1 s2 \<equiv> s2 \<preceq> s \<and> s1 \<preceq> s"

definition is_glb where
  "is_glb s s1 s2 \<equiv> is_lb s s1 s2 \<and> (\<forall> s' . is_lb s' s1 s2 \<longrightarrow> s' \<preceq> s)"

definition is_lub where
  "is_lub s s1 s2 \<equiv> is_ub s s1 s2 \<and> (\<forall> s' . is_ub s' s1 s2 \<longrightarrow> s \<preceq> s')"

definition contains where
  "contains s r \<equiv> \<exists> rs . r \<in> set rs \<and> s = (\<bottom> \<star> rs)"

definition inf  (infix "\<sqinter>" 65) where
  "inf s1 s2 \<equiv> THE s . is_glb s s1 s2"

definition sup  (infix "\<squnion>" 65) where
  "sup s1 s2 \<equiv> THE s . is_lub s s1 s2"

definition compat2 where
  -- {* Two c-structs are compatible when they have a common upper-bound. *}
  "compat2 s1 s2 \<equiv> \<exists> s3 . s1 \<preceq> s3 \<and> s2 \<preceq> s3"

definition compat where
  "compat S \<equiv> \<forall> s1 \<in> S . \<forall> s2 \<in> S .compat2 s1 s2"

subsection {* Lemmas in the pre-CStruct locale *}

lemma exec_cons:
  "s \<star> (rs # r)= (s \<star> rs) \<bullet> r" by simp

lemma exec_append:
  "(s \<star> rs) \<star> rs'  = s \<star> (rs@rs')"
by (induct rs') (simp, metis append_Cons exec_cons)

lemma trans:
  assumes "s1 \<preceq> s2" and "s2 \<preceq> s3"
  shows "s1 \<preceq> s3" using assms
    by (auto simp add:less_eq_def, metis exec_append)

lemma contains_star:
  fixes s r rs
  assumes "contains s r"
  shows "contains (s \<star> rs) r"
proof (induct rs)
  case Nil thus ?case using assms by auto
next
  case (Cons r' rs)
  with this obtain rs' where 1:"s \<star> rs = \<bottom> \<star> rs'" and 2:"r \<in> set rs'"
    by (auto simp add:contains_def)
  have 3:"s \<star> (rs#r') = \<bottom>\<star>(rs'#r')" using 1 by fastforce
  show "contains (s \<star> (rs#r')) r" using 2 3
    by (auto simp add:contains_def) (metis exec_cons set_rev_mp set_subset_Cons)
qed

lemma preceq_star: "s \<star> (rs#r) \<preceq> s' \<Longrightarrow> (s \<star> rs)  \<preceq> s'"
by (metis pre_CStruct.exec.simps(1) pre_CStruct.exec.simps(2) pre_CStruct.less_eq_def trans)

lemma compat_sym:"compat2 s1 s2 \<longleftrightarrow> compat2 s2 s1"
by (metis compat2_def)

lemma less_bullet:"s \<preceq> s \<bullet> c"
by (metis pre_CStruct.exec.simps(1) pre_CStruct.exec_cons pre_CStruct.less_eq_def)

end

subsection {* The CStruct locale *}

text {* Properties of CStructs *}

locale CStruct = pre_CStruct +
  assumes antisym:"\<And> s1 s2 . s1 \<preceq> s2 \<and> s2 \<preceq> s1 \<Longrightarrow> s1 = s2"
    -- {* antisym implies that @{term "op \<preceq>"} is a partial order*}
  and glb_exists:"\<And> s1 s2 . \<exists> s . is_glb s s1 s2"
  and glb_construct:"\<And> cs1 cs2 . is_glb s (\<bottom> \<star> cs1) (\<bottom> \<star> cs2)
    \<Longrightarrow> \<exists> cs . set cs \<subseteq> set cs1 \<union> set cs2 \<and> s = \<bottom> \<star> cs"
  and bot:"\<And> s . \<bottom> \<preceq> s"
  and lub_exists:"compat2 s1 s2 \<Longrightarrow> \<exists> s . is_lub s s1 s2"
  and lub_compat:"compat {s1,s2,s3} \<Longrightarrow> compat {(s1 \<squnion> s2), s3}"

begin

lemma inf_glb:"is_glb (s1 \<sqinter> s2) s1 s2"
proof -
  { fix s s'
    assume "is_glb s s1 s2" and "is_glb s' s1 s2"
    hence "s = s'" using antisym by (auto simp add:is_glb_def is_lb_def) }
    from this and glb_exists show ?thesis
      by (auto simp add:inf_def, metis (lifting) theI')
qed

lemma sup_lub:
  assumes "compat2 s1 s2"
  shows "is_lub (s1 \<squnion> s2) s1 s2"
proof -
  { fix s s'
    assume "is_lub s s1 s2" and "is_lub s' s1 s2"
    hence "s = s'" using antisym by (auto simp add:is_lub_def is_ub_def) }
    from this and lub_exists show ?thesis
      by (auto simp add:sup_def) (metis (lifting) assms theI)
qed

sublocale ordering less_eq less
  -- {* CStructs form a partial order *}
proof
  fix s
  show "s \<preceq> s"
  by (metis exec.simps(1) less_eq_def)
next
  fix s s'
  show "s \<prec> s' = (s \<preceq> s' \<and> s \<noteq> s')"
  by (auto simp add:less_def)
next
  fix s s'
  assume "s \<preceq> s'" and "s' \<preceq> s"
  thus "s = s'"
  using antisym by auto
next
  fix s1 s2 s3
  assume "s1 \<preceq> s2" and "s2 \<preceq> s3"
  thus "s1 \<preceq> s3"
  using trans by blast
qed

sublocale semilattice_set inf
proof
  fix s
  show "s \<sqinter> s = s"
    using inf_glb
    by (metis antisym is_glb_def is_lb_def refl)
next
  fix s1 s2
  show "s1 \<sqinter> s2 = (s2 \<sqinter> s1)"
    using inf_glb
    by (smt antisym is_glb_def pre_CStruct.is_lb_def)
next
  fix s1 s2 s3
  show "(s1 \<sqinter> s2) \<sqinter> s3 = (s1 \<sqinter> (s2 \<sqinter> s3))"
    using inf_glb
    by(auto simp add:is_glb_def is_lb_def, smt antisym trans)
qed

sublocale semilattice_order_set inf less_eq less
proof
  fix s s'
  show "s \<preceq> s' = (s = s \<sqinter> s')"
  by (metis antisym idem inf_glb pre_CStruct.is_glb_def pre_CStruct.is_lb_def)
next
  fix s s'
  show "s \<prec> s' = (s = s \<sqinter> s' \<and> s \<noteq> s')"
  by (metis inf_glb local.antisym local.refl pre_CStruct.is_glb_def pre_CStruct.is_lb_def pre_CStruct.less_def)
qed

notation F ("\<Sqinter> _" [99])
  -- {* The GLB of a set of c-structs. *}

lemma GLB_constuct:
  -- {* A direct consequence of glb_constuct*}
fixes ss rset
assumes "finite ss"  and "ss \<noteq> {}"
and "\<And> s . s \<in> ss \<Longrightarrow> \<exists> rs . s = \<bottom> \<star> rs \<and> set rs \<subseteq> rset"
shows "\<exists> rs . \<Sqinter> ss = \<bottom> \<star> rs \<and> set rs \<subseteq> rset"
using assms
proof (induct ss rule:finite_ne_induct)
  case (singleton s)
  obtain rs where "s = \<bottom> \<star> rs \<and> set rs \<subseteq> rset"
    using singleton.prems by auto
  moreover have "\<Sqinter> {s} = s" using singleton by auto
  ultimately show "\<exists> rs . \<Sqinter> {s} = \<bottom> \<star> rs \<and> set rs \<subseteq> rset" by blast
next
  case (insert s ss)
  have 1:"\<And> s' . s' \<in> ss \<Longrightarrow> \<exists> rs . s' = \<bottom> \<star> rs \<and> set rs \<subseteq> rset"
    using insert(5) by force
  obtain rs where 2:"\<Sqinter> ss = \<bottom> \<star> rs" and 3:"set rs \<subseteq> rset"
    using insert(4) 1 by blast
  obtain rs' where 4:"s = \<bottom> \<star> rs'"and 5:"set rs' \<subseteq> rset"
    using insert(5) by blast
  have 6:"\<Sqinter> (insert s ss) = s \<sqinter> (\<Sqinter> ss)"
    by (metis insert.hyps(1-3) insert_not_elem)
  obtain rs'' where 7:"\<Sqinter> (insert s ss) = \<bottom> \<star> rs''"
    and 8:"set rs'' \<subseteq> set rs' \<union> set rs"
    using 2 4 6 glb_construct by (metis inf_glb)
  have 9:"set rs'' \<subseteq> rset" using 3 5 8 by blast
  show "\<exists> rs . \<Sqinter> (insert s ss) = \<bottom> \<star> rs \<and> set rs \<subseteq> rset"
    using 7 9 by blast
qed

lemma GLB_constuct_obtains:
fixes ss rset
assumes "finite ss"  and "ss \<noteq> {}"
and "\<And> s . s \<in> ss \<Longrightarrow> \<exists> rs . s = \<bottom> \<star> rs \<and> set rs \<subseteq> rset"
obtains rs where "\<Sqinter> ss = \<bottom> \<star> rs" and "set rs \<subseteq> rset"
proof -
  from assms and GLB_constuct
  have "\<exists> rs . \<Sqinter> ss = \<bottom> \<star> rs \<and> set rs \<subseteq> rset" by simp
  with that show thesis by metis
qed

lemma glb_insert:"S \<noteq> {} \<Longrightarrow> \<Sqinter> (insert x S) \<preceq> \<Sqinter> S"
by (metis antimono finite_insert infinite order_iff_strict subset_insertI)

lemma glb_anti:"\<lbrakk>finite S; S \<noteq> {}; finite S'; S' \<noteq> {}; S \<subseteq> S'\<rbrakk> \<Longrightarrow> \<Sqinter>S' \<preceq> \<Sqinter>S"
  proof (induct S arbitrary:S' rule:finite_ne_induct)
    case (singleton s) thus ?case by (simp add: coboundedI)
    next
    case (insert s ss) thus ?case by (meson antimono insert_not_empty)
qed

lemma glb_singleton:"\<lbrakk>finite S; S \<noteq> {}; s \<in> S\<rbrakk> \<Longrightarrow> \<Sqinter>S \<preceq> s"
by (simp add: coboundedI)

end

end


theory Thm7AVL
imports
  "Thm7"
  "HOL-Data_Structures.AVL_Set"
begin

section "Strongly Joinable AVL Trees"

subsection "Join for AVL Trees"

fun joinR where
"joinR L a R = (case L of Node l (k,_) r \<Rightarrow>
 if ht r \<le> ht R + 1
 then balR l k (node r a R)
 else balR l k (joinR r a R))"

declare joinR.simps[simp del]

fun joinL where
"joinL L a R = (case R of Node l (k,_) r \<Rightarrow>
 if ht l \<le> ht L + 1
 then balL (node L a l) k r
 else balL (joinL L a l) k r)"

declare joinL.simps[simp del]

fun join where
"join l a r =
(if      ht l > ht r + 1 then joinR l a r
 else if ht r > ht l + 1 then joinL l a r
 else    node l a r)"

subsection "Proof of Correctness"
subsubsection "Set Preservation"

lemma balR_set:"set_tree (balR l a r) = set_tree
  l \<union> {a} \<union> set_tree r"
  by (auto simp: balR_def node_def split!: if_splits tree.splits)

lemma joinR_set:"ht l > ht r + 1 \<Longrightarrow> set_tree (joinR l a r) = set_tree
  l \<union> {a} \<union> set_tree r"
proof(induction l a r rule: joinR.induct)
  case (1 L a R)
  then show ?case
    by (auto simp: joinR.simps[of L a R] balR_set node_def split!: if_splits tree.splits)
qed

lemma balL_set:"set_tree (balL l a r) = set_tree
  l \<union> {a} \<union> set_tree r"
  by (auto simp: balL_def node_def split!: if_splits tree.splits)

lemma joinL_set:"ht r > ht l + 1 \<Longrightarrow> set_tree (joinL l a r) = set_tree
  l \<union> {a} \<union> set_tree r"
proof(induction l a r rule: joinL.induct)
  case (1 L a R)
  then show ?case
    by (auto simp: joinL.simps[of L a R]  balL_set node_def split!: if_splits tree.splits)
qed

corollary set_join:"set_tree (join l a r) = set_tree l \<union> {a} \<union> set_tree r"
  by(auto simp: node_def joinR_set joinL_set split!: if_splits)

subsubsection "BST Preservation"

lemma balR_bst:"\<lbrakk>bst l; bst r; \<forall>x\<in>set_tree l. x < a; \<forall>y\<in>set_tree r. a < y\<rbrakk>
  \<Longrightarrow> bst (balR l a r)"
  by (auto simp: balR_def node_def split!: if_splits tree.splits)

lemma joinR_bst:"\<lbrakk>ht l > ht r + 1; bst l; bst r; \<forall>x\<in>set_tree l. x < a; \<forall>y\<in>set_tree r. a < y\<rbrakk>
  \<Longrightarrow> bst (joinR l a r)"
proof(induction l a r arbitrary: b rule: joinR.induct)
  case (1 L a R)
  then show ?case
    by (auto simp: joinR.simps[of L a R] node_def balR_bst joinR_set ball_Un
      intro!: balR_bst split!: if_splits tree.splits)
qed

lemma balL_bst:"\<lbrakk>bst l; bst r; \<forall>x\<in>set_tree l. x < a; \<forall>y\<in>set_tree r. a < y\<rbrakk>
  \<Longrightarrow> bst (balL l a r)"
  by (auto simp: balL_def node_def split!: if_splits tree.splits)

lemma joinL_bst:"\<lbrakk>ht r > ht l + 1; bst l; bst r; \<forall>x\<in>set_tree l. x < a; \<forall>y\<in>set_tree r. a < y\<rbrakk>
\<Longrightarrow> bst (joinL l a r)"
proof(induction l a r arbitrary: b rule: joinL.induct)
  case (1 L a R)
  then show ?case
    by (auto simp: joinL.simps[of L a R] node_def balL_bst joinL_set ball_Un
      intro!: balL_bst split!: if_splits tree.splits)
qed

corollary bst_join:"bst (Node l (a, b) r) \<Longrightarrow> bst (join l a r)"
  by(auto simp: node_def joinR_bst joinL_bst split!: if_splits)

subsubsection "Preservation of AVL Predicate"
text\<open>Automatic proofs are relatively expensive in this section, expect a few minutes
runtime on low-powered machines.\<close>

lemma avl_joinR_height:"\<lbrakk>avl l; avl r; height l > height r + 1\<rbrakk>
\<Longrightarrow> avl (joinR l a r) \<and> height (joinR l a r) \<in> {height l, height l + 1}"
proof(induction l a r rule: joinR.induct)
  case (1 L a R)
  then show ?case
    by(auto simp: joinR.simps[of L a R] balR_def node_def max_absorb2 split!: if_splits tree.splits)
    \<comment> \<open>6 subgoals\<close>
    fastforce+
qed

lemma avl_joinL_height:"\<lbrakk>avl l; avl r; height r > height l + 1\<rbrakk>
\<Longrightarrow> avl (joinL l a r) \<and> height (joinL l a r) \<in> {height r, height r + 1}"
proof(induction l a r rule: joinL.induct)
  case (1 L a R)
  then show ?case
    by(auto simp: joinL.simps[of L a R] balL_def node_def max_absorb2 split!: if_splits tree.splits)
    \<comment> \<open>20 subgoals\<close>
    fastforce+
qed

corollary inv_join:"\<lbrakk>avl l; avl r\<rbrakk> \<Longrightarrow> avl (join l a r)"
  by(auto simp: node_def avl_joinR_height avl_joinL_height split: if_splits)

text \<open>To finish the proof of functional correctness, instantiate the \<open>Set2_Join\<close> locale.\<close>

interpretation tree_ht: Set2_Join
where join = join and inv = avl
proof (standard, goal_cases)
  case 1 show ?case by (rule set_join)
next
  case 2 thus ?case by (rule bst_join)
next
  case 3 show ?case by simp
next
  case 4 thus ?case by (rule inv_join)
next
  case 5 thus ?case by simp
qed

subsection "Proof of Strongly Joinable Properties"

subsubsection "Monoticity Rule"

corollary join_height:
assumes "avl l \<and> avl r"
shows "height (join l a r) \<in> {max (height l) (height r), max (height l) (height r) + 1}"
proof-
  consider
    (Right) R  where "R = joinR l a r" and "ht l > ht r + 1" and
                     "join l a r = R"
  | (Left)  L  where "L = joinL l a r" and "ht r > ht l + 1" and
                     "join l a r = L"
  | (Node)  EQ where "EQ = node l a r" and "ht r \<le> ht l + 1" and
                     "ht l \<le> ht r + 1" and "join l a r = EQ"
    by(auto split!: if_splits)linarith
  then show ?thesis
  proof cases
    case Right
    from this assms show ?thesis
      by (metis avl_joinR_height ht_height linorder_not_less max_def trans_le_add1)
  next
    case Left
    from this assms show ?thesis
      by (metis add_lessD1 ht_height avl_joinL_height max.absorb4)
  next
  next
    case Node
    then show ?thesis
      by simp
  qed
qed

corollary rule_mono: "\<lbrakk>avl l; avl r\<rbrakk> \<Longrightarrow> max (height l) (height r) \<le> height (join l a r)"
  using join_height
  by (metis insertE le_add_same_cancel1 zero_le_one nle_le singletonD)

subsubsection "Submodularity Rule"

corollary rule_sub_dec:
assumes "height l' \<le> height l \<and> height r' \<le> height r"
assumes "avl l' \<and> avl r' \<and> avl (Node l (a,b) r)"
shows "height (join l' a r') \<le> height (Node l (a,b) r)"
proof-
  from assms have "max (height l') (height r') \<le> max (height l) (height r)"
    by linarith
  moreover from assms have "height (join l' a r') \<le> max (height l') (height r') + 1"
    using join_height by (metis order_eq_iff insertE singletonD trans_le_add1)
  moreover have "height (Node l (a,b) r) = max (height l) (height r) + 1"
    by simp
  ultimately show ?thesis
    by linarith
qed

(* TODO maybe shorten this *)
lemma rule_sub_inc:
assumes "height l \<le> height l' \<and> height r \<le> height r'"
assumes "height r' - height r \<le> x \<and> height l' - height l \<le> x"
assumes "avl l' \<and> avl r' \<and> avl (Node l (a,b) r)"
shows "height (Node l (a,b) r) \<le> height (join l' a r') \<and>
  height (join l' a r') - height (Node l (a,b) r) \<le> x"
proof-
    have joinmax:"height (join l' a r') \<le> max (height l') (height r') + 1"
      using assms join_height by (metis order_eq_iff insertE singletonD trans_le_add1)
    show ?thesis
    proof(cases "height l \<ge> height r")
      case True
      then have "height (Node l (a,b) r) = height l + 1"
        using assms by simp
      moreover then have "max (height l') (height r') \<le> height l + x"
        using True assms by auto
      moreover then have "height (join l' a r') \<le> height l + x + 1"
        using assms joinmax by linarith
      moreover have "height (join l' a r') \<noteq> height l"
        proof(rule ccontr)
          assume *:"\<not> height (join l' a r') \<noteq> height l"
          moreover then have heq:"height l = height l'"
            by (metis assms(1) assms(3) le_antisym max.bounded_iff rule_mono)
          ultimately have "height r' \<le> height l'"
            by (metis assms(3) max.commute max_def rule_mono)
          moreover then have "join l' a r' = node l' a r'"
            using heq assms by auto
          ultimately have "height (join l' a r') = height l + 1 "
            using heq by simp
          then show False
            using * by linarith
          qed
      moreover have "height l \<le> height (join l' a r')"
        by (meson assms(1) assms(3) le_max_iff_disj order_trans rule_mono)
      ultimately show ?thesis
        by linarith
    next
      case False
      then have "height (Node l (a,b) r) = height r + 1"
        using assms by simp
      moreover then have "max (height l') (height r') \<le> height r + x"
        using False assms by auto
      moreover then have "height (join l' a r') \<le> height r + x + 1"
        using assms joinmax by linarith
      moreover have "height (join l' a r') \<noteq> height r"
        proof(rule ccontr)
          assume *:"\<not> height (join l' a r') \<noteq> height r"
          moreover then have heq:"height r = height r'"
            by (metis assms(1) assms(3) le_antisym max.bounded_iff rule_mono)
          ultimately have "height l' \<le> height r'"
            by (metis assms(3) max_def rule_mono)
          moreover then have "join l' a r' = node l' a r'"
            using heq assms by auto
          ultimately have "height (join l' a r') = height r + 1 "
            using heq by simp
          then show False
            using * by linarith
          qed
      moreover have "height r \<le> height (join l' a r')"
        by (meson assms(1) assms(3) le_max_iff_disj order_trans rule_mono)
      ultimately show ?thesis
        by linarith
    qed
qed

subsubsection "Balancing Rule"

lemma rule_bal: "avl t \<Longrightarrow> bal t height 1 2"
  by(induction t) auto

subsubsection "Cost Rule"

fun T_joinR :: "'a tree_ht \<Rightarrow> 'a \<Rightarrow> 'a tree_ht \<Rightarrow> nat" where
"T_joinR L a R = (case L of Node l (k,_) r \<Rightarrow>
 if ht r \<le> ht R + 1
 then 1
 else 1 + T_joinR r a R)"

declare T_joinR.simps[simp del]

fun T_joinL :: "'a tree_ht \<Rightarrow> 'a \<Rightarrow> 'a tree_ht \<Rightarrow> nat" where
"T_joinL L a R = (case R of Node l (k,_) r \<Rightarrow>
 if ht l \<le> ht L + 1
 then 1
 else 1 + T_joinL L a l)"

declare T_joinL.simps[simp del]

fun T_join :: "'a tree_ht \<Rightarrow> 'a \<Rightarrow> 'a tree_ht \<Rightarrow> nat" where
"T_join l a r =
(if      ht l > ht r + 1 then T_joinR l a r
 else if ht r > ht l + 1 then T_joinL l a r
 else    1)"

lemma T_joinR:"\<lbrakk>avl l; avl r; ht l > ht r + 1\<rbrakk> \<Longrightarrow> T_joinR l a r \<le> 1 + height l - height r"
proof(induction l a r rule: T_joinR.induct)
  case (1 L a R)
  then show ?case
    using T_joinR.simps[of L a R]
    by(auto simp: max_absorb2 split!: if_splits tree.splits) fastforce
qed

lemma T_joinL:"\<lbrakk>avl l; avl r; ht r > ht l + 1\<rbrakk> \<Longrightarrow> T_joinL l a r \<le> 1 + height r - height l"
proof(induction l a r rule: T_joinL.induct)
  case (1 L a R)
  then show ?case
    by(auto simp: T_joinL.simps[of L a R] max_absorb1 split!: if_splits tree.splits) fastforce
qed

corollary rule_cost:
assumes "avl l \<and> avl r"
shows "T_join l a r \<le> 1 + nat(abs(int(height l) - int(height r)))"
proof-
  consider
    (Right) R where "R = T_joinR l a r" and "ht l > ht r + 1" and
                    "T_join l a r = R"
  | (Left)  L where "L = T_joinL l a r" and "ht r > ht l + 1" and
                    "T_join l a r = L"
  | (Node)  EQ where "EQ = 1" and "ht r \<le> ht l + 1" and
                     "ht l \<le> ht r + 1" and "T_join l a r = EQ"
    by(auto split!: if_splits)linarith
  then show ?thesis
  proof cases
    case Right
    then have "max (height l) (height r) = height l"
      using assms by simp
    then moreover have "nat(abs(int(height l) - int(height r))) = height l - height r"
      by simp
    ultimately show ?thesis
      using Right T_joinR assms by (metis Nat.add_diff_assoc max.orderI)
  next
    case Left
    then have "max (height l) (height r) = height r"
      using assms by simp
    then moreover have "nat(abs(int(height l) - int(height r))) = height r - height l"
      by simp
    ultimately show ?thesis
      using Left T_joinL assms by (metis Nat.add_diff_assoc max.cobounded1)
  next
    case Node
    then show ?thesis
      by simp
  qed
qed

interpretation tree_ht: StronglyJoinable
where join = join and inv = avl
and rank = height and c\<^sub>l = 1 and c\<^sub>u = 2
proof (standard, goal_cases)
  case 1 thus ?case by simp
next
  case (2 l r a) thus ?case by (metis of_nat_le_iff of_nat_max rule_mono)
next
  \<comment> \<open>this simply converts from nat to real, but takes a long time to run, expect a few minutes\<close>
  case (3 l' l r' r x a b)
  then show ?case
    by (smt (verit) diff_diff_cancel diff_le_self le_diff_iff' nat_le_linear of_nat_diff of_nat_le_iff of_nat_mono ord_le_eq_subst rule_sub_inc)
next
  case (4 l' l r' r a b) thus ?case
    by (meson of_nat_le_iff rule_sub_dec)
next
  case 5 thus ?case by simp
next
  case (6 t) thus ?case by(rule rule_bal)
qed

end


theory tut4 imports Main
begin

lemma 1: "(P ⟶(Q⟶R))⟶((P⟶Q)⟶(P⟶R))"
proof (rule impI)+
  assume 1: "(P ⟶(Q⟶R))" and 2: "P⟶Q" and 3: "P"
  from 2 and 3
  have 4: "Q" by (rule mp)
  from 1 and 3
  have 5: "Q⟶R" by (rule mp)
  from 5 and 4
  show "R" by (rule mp) (* replace with blast *)
qed

lemma 2: "(∀x. P x ⟶ Q) ⟶ (∃x. P x ⟶ Q)"
proof
  assume "(∀x. P x ⟶ Q)" then have "P a ⟶ Q"
    by (simp add: ‹∀x. P x ⟶ Q›)
  then show "(∃x. P x ⟶ Q)"
    by simp
qed

lemma three_try: "¬(∃x. P x) ⟹ (∀x.¬P x)"
  apply (rule allI)
  apply (rule notI)
  apply (erule notE)
  apply (rule exI)
  apply assumption
  done

lemma 3: "¬(∃x. P x) ⟹ (∀x.¬P x)"
proof (rule allI, rule notI)
  fix x
  assume forContra: "P x"
  have 0: "∃x. P x"
    using forContra by (rule exI)
  assume notExist: "∄x. P x"
  then show "False"
    using forContra by auto
qed

lemma 31: "¬(∃x. P x) ⟹ (∀x.¬P x)"
proof (safe)
  fix x
  assume "P x" then have "(∃x. P x)" ..
  assume ex: "¬(∃x. P x)"
  then show False using ex
    using ‹P x› by auto
qed

(* safe is a method that will not make any provable goal become unprovable.
It does not do any exI or spec/allE steps. You can use other methods instead. *)

lemma assumes n_all: "¬(∀x. P x)" shows "∃x. ¬P x"
proof (rule ccontr)
  assume n_ex: "∄x. ¬ P x"
  { fix x
    have "P x"
    proof (rule ccontr)
      assume "¬P x" then have "∃x. ¬P x" ..
      then show False using n_ex by simp
    qed
  }
  then have "∀x. P x" ..
  then show False using n_all by simp
qed

lemma 5: "(R⟶P)⟶(((¬R ∨ P)⟶(Q⟶S))⟶(Q⟶S))"
proof (rule impI)+
  assume "R ⟶ P" and "¬R ∨ P ⟶ Q ⟶ S" and "Q"
  show "S"
  (* show the possible cases:
      1. R
      2. ¬R
  *)
  proof (cases)
    assume "R"
    then have "P"
      using ‹R ⟶ P› by blast
    then have "¬R ∨ P"
      by simp
    then have "Q ⟶ S"
      using ‹¬ R ∨ P ⟶ Q ⟶ S› by blast
    then show "S"
      using ‹Q› by simp
  next
    assume "¬R"
    then have "¬R ∨ P"
      by simp
    then have "Q ⟶ S"
      using ‹¬ R ∨ P ⟶ Q ⟶ S› by blast
    then show "S"
      using ‹Q› by simp
  qed
qed

end


theory prop_72
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun take :: "Nat => Nat list => Nat list" where
  "take (Z) y = Nil2"
  | "take (S z) (Nil2) = Nil2"
  | "take (S z) (Cons2 x2 x3) = Cons2 x2 (take z x3)"
  fun minus :: "Nat => Nat => Nat" where
  "minus (Z) y = Z"
  | "minus (S z) (Z) = S z"
  | "minus (S z) (S x2) = minus z x2"
  fun len :: "'a list => Nat" where
  "len (Nil2) = Z"
  | "len (Cons2 y xs) = S (len xs)"
  fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
  | "drop (S z) (Nil2) = Nil2"
  | "drop (S z) (Cons2 x2 x3) = drop z x3"
  fun append :: "Nat list => Nat list => Nat list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  fun rev :: "Nat list => Nat list" where
  "rev (Nil2) = Nil2"
  | "rev (Cons2 y xs) = append (rev xs) (Cons2 y (Nil2))"
  (*hipster take minus len drop append rev *)

lemma lemma_da [thy_expl]: "drop x3 Nil2 = Nil2"
by (hipster_induct_schemes drop.simps)

lemma lemma_daa [thy_expl]: "drop (S Z) (drop x3 y3) = drop (S x3) y3"
by (hipster_induct_schemes drop.simps)

lemma lemma_dab [thy_expl]: "drop x (drop y z) = drop y (drop x z)"
by (hipster_induct_schemes drop.simps Nat.exhaust)

lemma lemma_ah [thy_expl]: "drop (len x2) x2 = Nil2"
by (hipster_induct_schemes len.simps append.simps rev.simps drop.simps take.simps minus.simps)

lemma lemma_ta [thy_expl]: "take x2 (take x2 y2) = take x2 y2"
by (hipster_induct_schemes take.simps)

lemma lemma_taa [thy_expl]: "take x1 (take Z y1) = take Z y1"
by (hipster_induct_schemes take.simps)

lemma lemma_tab [thy_expl]: "take (S x2) (take x2 y2) = take x2 y2"
by (hipster_induct_schemes take.simps)

lemma lemma_tac []: "take x (take y z) = take y (take x z)"
apply(induction y z arbitrary: x rule: take.induct)
apply(simp_all)
apply(metis take.simps thy_expl)
apply(metis take.simps thy_expl)
by (metis take.simps list.exhaust Nat.exhaust)

lemma lemma_a [thy_expl]: "minus x2 x2 = Z"
by (hipster_induct_schemes minus.simps)

lemma lemma_aa [thy_expl]: "minus x3 Z = x3"
by (hipster_induct_schemes minus.simps)

lemma lemma_ab [thy_expl]: "minus x2 (S x2) = Z"
by (hipster_induct_schemes)

lemma lemma_ac [thy_expl]: "minus (S x2) x2 = S Z"
by (hipster_induct_schemes)

lemma lemma_ad [thy_expl]: "minus (minus x3 y3) (minus y3 x3) = minus x3 y3"
by (hipster_induct_schemes minus.simps)

lemma lemma_ae [thy_expl]: "minus (minus x3 y3) (S Z) = minus x3 (S y3)"
by (hipster_induct_schemes minus.simps)

lemma lemma_af [thy_expl]: "minus (minus x4 y4) x4 = Z"
by (hipster_induct_schemes minus.simps)

lemma lemma_aq [thy_expl]: "append x2 Nil2 = x2"
by (hipster_induct_schemes append.simps)

lemma lemma_ar [thy_expl]: "append (append x1 y1) z1 = append x1 (append y1 z1)"
by (hipster_induct_schemes append.simps)

lemma lemma_as [thy_expl]: "minus (len x3) y3 = len (drop y3 x3)"
by (hipster_induct_schemes rev.simps append.simps take.simps drop.simps len.simps minus.simps)

lemma lemma_at [thy_expl]: "append (take x2 y2) (drop x2 y2) = y2"
by (hipster_induct_schemes rev.simps append.simps take.simps drop.simps len.simps minus.simps)

lemma lemma_au [thy_expl]: "append (rev x4) (rev y4) = rev (append y4 x4)"
by (hipster_induct_schemes rev.simps append.simps take.simps drop.simps len.simps minus.simps)

lemma lemma_av [thy_expl]: "take (len x2) (append x2 y2) = x2"
by (hipster_induct_schemes rev.simps append.simps take.simps drop.simps len.simps minus.simps)

lemma lemma_aw [thy_expl]: "drop (len x2) (append x2 y2) = y2"
by (hipster_induct_schemes rev.simps append.simps take.simps drop.simps len.simps minus.simps)

lemma lemma_ax [thy_expl]: "take (S Z) (append x1 x1) = take (S Z) x1"
by (hipster_induct_schemes append.simps take.simps)

lemma lemma_ay [thy_expl]: "rev (rev x3) = x3"
by (hipster_induct_schemes rev.simps append.simps take.simps drop.simps len.simps minus.simps)

(*
4: xs++[] == xs
5: []++xs == xs
6: (x:xs)++ys == x:(xs++ys)
7: (xs++ys)++zs == xs++(ys++zs)

== Equations about several functions ==
8: (length (xs++ys)) == (length (ys++xs))
9: (length (x:(xs++ys))) == (length (x:(ys++xs)))
10: (length (xs++(ys++zs))) == (length (xs++(zs++ys)))
11: (length ((x:xs)++(y:ys))) == (length ((x:xs)++(z:ys)))
12: (length ((x:xs)++(ys++zs))) == (length ((x:ys)++(xs++zs)))
13: (length ((x:xs)++(ys++zs))) == (length ((y:xs)++(ys++zs)))
14: (length ((xs++ys)++(zs++ys))) == (length ((xs++zs)++(ys++ys)))*)

lemma ax2[thy_expl]: "len (append y (Cons2 ya xs)) = S (len (append y xs))"
by(hipster_induct_schemes)

lemma lemma_applen [thy_expl]: "len (append x y) = len (append y x)"
(*apply(induction x)
apply(simp_all)
apply(metis thy_expl append.simps len.simps)*)
by (hipster_induct_schemes)

lemma lemma_revlen [thy_expl]: "len (rev x) = len x"
by (hipster_induct_schemes len.simps rev.simps)

lemma lemma_takerev [thy_expl]: "take (len x) (rev x) = rev x"
by (hipster_induct_schemes take.simps len.simps rev.simps append.simps)

lemma lemma_droprev [thy_expl]: "drop (len x) (rev x) = Nil2"
by (hipster_induct_schemes drop.simps len.simps rev.simps)
(*hipster len append rev drop take minus*)

setup\<open>Hip_Tac_Ops.set_metis_to @{context} 800\<close>

lemma unknown [thy_expl]: "minus (minus x y) z = minus (minus x z) y"
oops

lemma unknown [thy_expl]: "minus x (minus x y) = minus y (minus y x)"
oops

lemma unknown [thy_expl]: "minus (minus x y) (minus z y) =
minus (minus x z) (minus y z)"
oops

lemma unknown [thy_expl]: "minus (minus x y) (S z) =
minus (minus x z) (S y)"
oops

lemma unknown [thy_expl]: "minus (minus x y) (minus x z) =
minus (minus z y) (minus z x)"
oops

lemma unknown [thy_expl]: "drop (minus x y) (drop y z) =
drop (minus y x) (drop x z)"
oops

lemma unknown [thy_expl]: "take (minus x y) (take x z) =
take (minus x y) z"
oops

lemma unknown [thy_expl]: "drop (S x) (drop y z) =
drop (S y) (drop x z)"
oops

lemma unknown [thy_expl]: "minus (S x) (minus x y) =
minus (S y) (minus y x)"
oops

lemma unknown [thy_expl]: "drop (S x) (drop y z) =
drop (S y) (drop x z)"
oops

  theorem x0 :
    "(rev (drop i xs)) = (take (minus (len xs) i) (rev xs))"
by (hipster_induct_schemes rev.simps append.simps take.simps drop.simps len.simps minus.simps Nat.exhaust list.exhaust)

    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory Chapter3
imports "~~/src/HOL/IMP/BExp"
        "~~/src/HOL/IMP/ASM"
begin

text{*
\section*{Chapter 3}

\exercise
To show that @{const asimp_const} really folds all subexpressions of the form
@{term "Plus (N i) (N j)"}, define a function
*}

fun optimal :: "aexp \<Rightarrow> bool" where
"optimal (N n) = True" |
"optimal (V x) = True" |
"optimal (Plus (N a) (N b)) = False" |
"optimal (Plus a b) = ((optimal a) \<and> (optimal b))"

text{*
that checks that its argument does not contain a subexpression of the form
@{term "Plus (N i) (N j)"}. Then prove that the result of @{const asimp_const}
is optimal:
*}

lemma "optimal (asimp_const a)"
  apply (induction a)
  apply (simp split: aexp.split)
  apply (simp split: aexp.split)
  apply (simp split: aexp.split)
  apply (auto split: aexp.split)
done

text{*
This proof needs the same @{text "split:"} directive as the correctness proof of
@{const asimp_const}. This increases the chance of nontermination
of the simplifier. Therefore @{const optimal} should be defined purely by
pattern matching on the left-hand side,
without @{text case} expressions on the right-hand side.
\endexercise

\exercise
In this exercise we verify constant folding for @{typ aexp}
where we sum up all constants, even if they are not next to each other.
For example, @{term "Plus (N 1) (Plus (V x) (N 2))"} becomes
@{term "Plus (V x) (N 3)"}. This goes beyond @{const asimp}.
Below we follow a particular solution strategy but there are many others.

First, define a function @{text sumN} that returns the sum of all
constants in an expression and a function @{text zeroN} that replaces all
constants in an expression by zeroes (they will be optimized away later):
*}

fun sumN :: "aexp \<Rightarrow> int" where
(* your definition/proof here *)

fun zeroN :: "aexp \<Rightarrow> aexp" where
(* your definition/proof here *)

text {*
Next, define a function @{text sepN} that produces an arithmetic expression
that adds the results of @{const sumN} and @{const zeroN}. Prove that
@{text sepN} preserves the value of an expression.
*}

definition sepN :: "aexp \<Rightarrow> aexp" where
(* your definition/proof here *)

lemma aval_sepN: "aval (sepN t) s = aval t s"
(* your definition/proof here *)

text {*
Finally, define a function @{text full_asimp} that uses @{const asimp}
to eliminate the zeroes left over by @{const sepN}.
Prove that it preserves the value of an arithmetic expression.
*}

definition full_asimp :: "aexp \<Rightarrow> aexp" where
(* your definition/proof here *)

lemma aval_full_asimp: "aval (full_asimp t) s = aval t s"
(* your definition/proof here *)

text{*
\endexercise

\exercise\label{exe:subst}
Substitution is the process of replacing a variable
by an expression in an expression. Define a substitution function
*}

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
(* your definition/proof here *)

text{*
such that @{term "subst x a e"} is the result of replacing
every occurrence of variable @{text x} by @{text a} in @{text e}.
For example:
@{lemma[display] "subst ''x'' (N 3) (Plus (V ''x'') (V ''y'')) = Plus (N 3) (V ''y'')" by simp}

Prove the so-called \concept{substitution lemma} that says that we can either
substitute first and evaluate afterwards or evaluate with an updated state:
*}

lemma subst_lemma: "aval (subst x a e) s = aval e (s(x := aval a s))"
(* your definition/proof here *)

text {*
As a consequence prove that we can substitute equal expressions by equal expressions
and obtain the same result under evaluation:
*}
lemma "aval a1 s = aval a2 s
  \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
(* your definition/proof here *)

text{*
\endexercise

\exercise
Take a copy of theory @{theory AExp} and modify it as follows.
Extend type @{typ aexp} with a binary constructor @{text Times} that
represents multiplication. Modify the definition of the functions @{const aval}
and @{const asimp} accordingly. You can remove @{const asimp_const}.
Function @{const asimp} should eliminate 0 and 1 from multiplications
as well as evaluate constant subterms. Update all proofs concerned.
*}

text{*
\endexercise

\exercise
Define a datatype @{text aexp2} of extended arithmetic expressions that has,
in addition to the constructors of @{typ aexp}, a constructor for
modelling a C-like post-increment operation $x{++}$, where $x$ must be a
variable. Define an evaluation function @{text "aval2 :: aexp2 \<Rightarrow> state \<Rightarrow> val \<times> state"}
that returns both the value of the expression and the new state.
The latter is required because post-increment changes the state.

Extend @{text aexp2} and @{text aval2} with a division operation. Model partiality of
division by changing the return type of @{text aval2} to
@{typ "(val \<times> state) option"}. In case of division by 0 let @{text aval2}
return @{const None}. Division on @{typ int} is the infix @{text div}.
*}

text{*
\endexercise

\exercise
The following type adds a @{text LET} construct to arithmetic expressions:
*}

datatype lexp = Nl int | Vl vname | Plusl lexp lexp | LET vname lexp lexp

text{* The @{const LET} constructor introduces a local variable:
the value of @{term "LET x e\<^sub>1 e\<^sub>2"} is the value of @{text e\<^sub>2}
in the state where @{text x} is bound to the value of @{text e\<^sub>1} in the original state.
Define a function @{const lval} @{text"::"} @{typ "lexp \<Rightarrow> state \<Rightarrow> int"}
that evaluates @{typ lexp} expressions. Remember @{term"s(x := i)"}.

Define a conversion @{const inline} @{text"::"} @{typ "lexp \<Rightarrow> aexp"}.
The expression \mbox{@{term "LET x e\<^sub>1 e\<^sub>2"}} is inlined by substituting
the converted form of @{text e\<^sub>1} for @{text x} in the converted form of @{text e\<^sub>2}.
See Exercise~\ref{exe:subst} for more on substitution.
Prove that @{const inline} is correct w.r.t.\ evaluation.
\endexercise

\exercise
Show that equality and less-or-equal tests on @{text aexp} are definable
*}

definition Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
(* your definition/proof here *)

definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
(* your definition/proof here *)

text{*
and prove that they do what they are supposed to:
*}

lemma bval_Le: "bval (Le a1 a2) s = (aval a1 s \<le> aval a2 s)"
(* your definition/proof here *)

lemma bval_Eq: "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
(* your definition/proof here *)

text{*
\endexercise

\exercise
Consider an alternative type of boolean expressions featuring a conditional: *}

datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp

text {*  First define an evaluation function analogously to @{const bval}: *}

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
(* your definition/proof here *)

text{* Then define two translation functions *}

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
(* your definition/proof here *)

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
(* your definition/proof here *)

text{* and prove their correctness: *}

lemma "bval (if2bexp exp) s = ifval exp s"
(* your definition/proof here *)

lemma "ifval (b2ifexp exp) s = bval exp s"
(* your definition/proof here *)

text{*
\endexercise

\exercise
We define a new type of purely boolean expressions without any arithmetic
*}

datatype pbexp =
  VAR vname | NOT pbexp | AND pbexp pbexp | OR pbexp pbexp

text{*
where variables range over values of type @{typ bool},
as can be seen from the evaluation function:
*}

fun pbval :: "pbexp \<Rightarrow> (vname \<Rightarrow> bool) \<Rightarrow> bool" where
"pbval (VAR x) s = s x"  |
"pbval (NOT b) s = (\<not> pbval b s)" |
"pbval (AND b1 b2) s = (pbval b1 s \<and> pbval b2 s)" |
"pbval (OR b1 b2) s = (pbval b1 s \<or> pbval b2 s)"

text {* Define a function that checks whether a boolean exression is in NNF
(negation normal form), i.e., if @{const NOT} is only applied directly
to @{const VAR}s: *}

fun is_nnf :: "pbexp \<Rightarrow> bool" where
(* your definition/proof here *)

text{*
Now define a function that converts a @{text bexp} into NNF by pushing
@{const NOT} inwards as much as possible:
*}

fun nnf :: "pbexp \<Rightarrow> pbexp" where
(* your definition/proof here *)

text{*
Prove that @{const nnf} does what it is supposed to do:
*}

lemma pbval_nnf: "pbval (nnf b) s = pbval b s"
(* your definition/proof here *)

lemma is_nnf_nnf: "is_nnf (nnf b)"
(* your definition/proof here *)

text{*
An expression is in DNF (disjunctive normal form) if it is in NNF
and if no @{const OR} occurs below an @{const AND}. Define a corresponding
test:
*}

fun is_dnf :: "pbexp \<Rightarrow> bool" where
(* your definition/proof here *)

text {*
An NNF can be converted into a DNF in a bottom-up manner.
The critical case is the conversion of @{term (sub) "AND b1 b2"}.
Having converted @{text b\<^sub>1} and @{text b\<^sub>2}, apply distributivity of @{const AND}
over @{const OR}. If we write @{const OR} as a multi-argument function,
we can express the distributivity step as follows:
@{text "dist_AND (OR a\<^sub>1 ... a\<^sub>n) (OR b\<^sub>1 ... b\<^sub>m)"}
= @{text "OR (AND a\<^sub>1 b\<^sub>1) (AND a\<^sub>1 b\<^sub>2) ... (AND a\<^sub>n b\<^sub>m)"}. Define
*}

fun dist_AND :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
(* your definition/proof here *)

text {* and prove that it behaves as follows: *}

lemma pbval_dist: "pbval (dist_AND b1 b2) s = pbval (AND b1 b2) s"
(* your definition/proof here *)

lemma is_dnf_dist: "is_dnf b1 \<Longrightarrow> is_dnf b2 \<Longrightarrow> is_dnf (dist_AND b1 b2)"
(* your definition/proof here *)

text {* Use @{const dist_AND} to write a function that converts an NNF
  to a DNF in the above bottom-up manner.
*}

fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
(* your definition/proof here *)

text {* Prove the correctness of your function: *}

lemma "pbval (dnf_of_nnf b) s = pbval b s"
(* your definition/proof here *)

lemma "is_nnf b \<Longrightarrow> is_dnf (dnf_of_nnf b)"
(* your definition/proof here *)

text{*
\endexercise

\exercise\label{exe:stack-underflow}
A \concept{stack underflow} occurs when executing an @{text ADD}
instruction on a stack of size less than two. In our semantics
stack underflow leads to a term involving @{term "hd []"},
which is not an error or exception --- HOL does not
have those concepts --- but some unspecified value. Modify
theory @{theory ASM} such that stack underflow is modelled by @{const None}
and normal execution by @{text Some}, i.e., the execution functions
have return type @{typ "stack option"}. Modify all theorems and proofs
accordingly.
Hint: you may find @{text"split: option.split"} useful in your proofs.
*}

text{*
\endexercise

\exercise\label{exe:register-machine}
This exercise is about a register machine
and compiler for @{typ aexp}. The machine instructions are
*}
type_synonym reg = nat
datatype instr = LDI val reg | LD vname reg | ADD reg reg

text {*
where type @{text reg} is a synonym for @{typ nat}.
Instruction @{term "LDI i r"} loads @{text i} into register @{text r},
@{term "LD x r"} loads the value of @{text x} into register @{text r},
and @{term[names_short] "ADD r\<^sub>1 r\<^sub>2"} adds register @{text r\<^sub>2} to register @{text r\<^sub>1}.

Define the execution of an instruction given a state and a register state;
the result is the new register state: *}

type_synonym rstate = "reg \<Rightarrow> val"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
(* your definition/proof here *)

text{*
Define the execution @{const[source] exec} of a list of instructions as for the stack machine.

The compiler takes an arithmetic expression @{text a} and a register @{text r}
and produces a list of instructions whose execution places the value of @{text a}
into @{text r}. The registers @{text "> r"} should be used in a stack-like fashion
for intermediate results, the ones @{text "< r"} should be left alone.
Define the compiler and prove it correct:
*}

theorem "exec (comp a r) s rs r = aval a s"
(* your definition/proof here *)

text{*
\endexercise

\exercise\label{exe:accumulator}
This exercise is a variation of the previous one
with a different instruction set:
*}

datatype instr0 = LDI0 val | LD0 vname | MV0 reg | ADD0 reg

text{*
All instructions refer implicitly to register 0 as a source or target:
@{const LDI0} and @{const LD0} load a value into register 0, @{term "MV0 r"}
copies the value in register 0 into register @{text r}, and @{term "ADD0 r"}
adds the value in register @{text r} to the value in register 0;
@{term "MV0 0"} and @{term "ADD0 0"} are legal. Define the execution functions
*}

fun exec01 :: "instr0 \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
(* your definition/proof here *)

text{*
and @{const exec0} for instruction lists.

The compiler takes an arithmetic expression @{text a} and a register @{text r}
and produces a list of instructions whose execution places the value of @{text a}
into register 0. The registers @{text "> r"} should be used in a stack-like fashion
for intermediate results, the ones @{text "\<le> r"} should be left alone
(with the exception of 0). Define the compiler and prove it correct:
*}

theorem "exec0 (comp0 a r) s rs 0 = aval a s"
(* your definition/proof here *)

text{*
\endexercise
*}

end


theory 10
  imports Main "~~/src/HOL/Library/Code_Target_Nat"
begin

  (* section 2.5 *)

  (* I don't understand this:
In particular, let-expressions can be unfolded by making Let_def a simplification
rule *)

  (* exercise 2.10 *)
datatype tree0 = Leaf | Node tree0 tree0

fun nodes :: "tree0 \<Rightarrow> nat" where
  "nodes Leaf = Suc 0"|
  "nodes (Node l r) = Suc(nodes l + nodes r)"

value "nodes Leaf"
value "nodes (Node Leaf Leaf)"

fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
  "explode 0 t = t" |
  "explode (Suc n) t = explode n (Node t t)"

value "nodes (explode 1 (Node Leaf Leaf))" (* x*2+1 where x=3, is 7 *)
value "nodes (explode 2 (Node Leaf Leaf))" (* do it twice where x=3, is 15 *)

value "nodes (explode 1 (Leaf))" (* x*2+1 where x=1, is 3 *)
value "nodes (explode 2 (Leaf))" (* do it twice where x=1, is 7 *)

value "nodes (explode 1 (Node Leaf (Node Leaf Leaf)))" (* go once where x=5, is 11 *)
value "nodes (explode 2 (Node Leaf (Node Leaf Leaf)))" (* go twice where x=5, is 23 *)

value "x*2+1 :: int"
value "(x*2+1)*2+1 :: int"

  (* Find an equation expressing the size of a tree after exploding it (nodes
(explode n t)) as a function of nodes t and n. Prove your equation   *)
lemma nodes_explode[simp]: "nodes (explode n t) = (2^n) * (nodes t) + (2^n - 1)"

  (* apply(induction n) *)
  (* After simp_all, this goal remains:
 1. \<And>n. nodes (explode n t) = 2 ^ n + nodes t * 2 ^ n - Suc 0 \<Longrightarrow>
         nodes (explode n (Node t t)) = 2 * 2 ^ n + nodes t * (2 * 2 ^ n) - Suc 0 *)

  apply(induction n arbitrary: t)
   apply(simp_all add: algebra_simps)
  done

end


(*<*)
theory simplification imports Main begin
(*>*)

text{*
Once we have proved all the termination conditions, the \isacommand{recdef}
recursion equations become simplification rules, just as with
\isacommand{primrec}. In most cases this works fine, but there is a subtle
problem that must be mentioned: simplification may not
terminate because of automatic splitting of @{text "if"}.
\index{*if expressions!splitting of}
Let us look at an example:
*}

consts gcd :: "nat\<times>nat \<Rightarrow> nat"
recdef gcd "measure (\<lambda>(m,n).n)"
  "gcd (m, n) = (if n=0 then m else gcd(n, m mod n))"

text{*\noindent
According to the measure function, the second argument should decrease with
each recursive call. The resulting termination condition
@{term[display]"n ~= (0::nat) ==> m mod n < n"}
is proved automatically because it is already present as a lemma in
HOL\@.  Thus the recursion equation becomes a simplification
rule. Of course the equation is nonterminating if we are allowed to unfold
the recursive call inside the @{text else} branch, which is why programming
languages and our simplifier don't do that. Unfortunately the simplifier does
something else that leads to the same problem: it splits
each @{text "if"}-expression unless its
condition simplifies to @{term True} or @{term False}.  For
example, simplification reduces
@{term[display]"gcd(m,n) = k"}
in one step to
@{term[display]"(if n=0 then m else gcd(n, m mod n)) = k"}
where the condition cannot be reduced further, and splitting leads to
@{term[display]"(n=0 --> m=k) & (n ~= 0 --> gcd(n, m mod n)=k)"}
Since the recursive call @{term"gcd(n, m mod n)"} is no longer protected by
an @{text "if"}, it is unfolded again, which leads to an infinite chain of
simplification steps. Fortunately, this problem can be avoided in many
different ways.

The most radical solution is to disable the offending theorem
@{thm[source]if_split},
as shown in \S\ref{sec:AutoCaseSplits}.  However, we do not recommend this
approach: you will often have to invoke the rule explicitly when
@{text "if"} is involved.

If possible, the definition should be given by pattern matching on the left
rather than @{text "if"} on the right. In the case of @{term gcd} the
following alternative definition suggests itself:
*}

consts gcd1 :: "nat\<times>nat \<Rightarrow> nat"
recdef gcd1 "measure (\<lambda>(m,n).n)"
  "gcd1 (m, 0) = m"
  "gcd1 (m, n) = gcd1(n, m mod n)"

text{*\noindent
The order of equations is important: it hides the side condition
@{prop"n ~= (0::nat)"}.  Unfortunately, in general the case distinction
may not be expressible by pattern matching.

A simple alternative is to replace @{text "if"} by @{text case},
which is also available for @{typ bool} and is not split automatically:
*}

consts gcd2 :: "nat\<times>nat \<Rightarrow> nat"
recdef gcd2 "measure (\<lambda>(m,n).n)"
  "gcd2(m,n) = (case n=0 of True \<Rightarrow> m | False \<Rightarrow> gcd2(n,m mod n))"

text{*\noindent
This is probably the neatest solution next to pattern matching, and it is
always available.

A final alternative is to replace the offending simplification rules by
derived conditional ones. For @{term gcd} it means we have to prove
these lemmas:
*}

lemma [simp]: "n \<noteq> 0 \<Longrightarrow> gcd(m, n) = gcd(n, m mod n)"
apply(simp)
done

text{*\noindent
Simplification terminates for these proofs because the condition of the @{text
"if"} simplifies to @{term True} or @{term False}.
Now we can disable the original simplification rule:
*}

declare gcd.simps [simp del]

(*<*)
end
(*>*)


(*  Title:      HOL/Library/Quotient_Type.thy
    Author:     Markus Wenzel, TU Muenchen
*)

section {* Quotient types *}

theory Quotient_Type
imports Main
begin

text {*
 We introduce the notion of quotient types over equivalence relations
 via type classes.
*}

subsection {* Equivalence relations and quotient types *}

text {*
 \medskip Type class @{text equiv} models equivalence relations @{text
 "\<sim> :: 'a => 'a => bool"}.
*}

class eqv =
  fixes eqv :: "'a \<Rightarrow> 'a \<Rightarrow> bool"    (infixl "\<sim>" 50)

class equiv = eqv +
  assumes equiv_refl [intro]: "x \<sim> x"
  assumes equiv_trans [trans]: "x \<sim> y \<Longrightarrow> y \<sim> z \<Longrightarrow> x \<sim> z"
  assumes equiv_sym [sym]: "x \<sim> y \<Longrightarrow> y \<sim> x"

lemma equiv_not_sym [sym]: "\<not> (x \<sim> y) ==> \<not> (y \<sim> (x::'a::equiv))"
proof -
  assume "\<not> (x \<sim> y)" then show "\<not> (y \<sim> x)"
    by (rule contrapos_nn) (rule equiv_sym)
qed

lemma not_equiv_trans1 [trans]: "\<not> (x \<sim> y) ==> y \<sim> z ==> \<not> (x \<sim> (z::'a::equiv))"
proof -
  assume "\<not> (x \<sim> y)" and "y \<sim> z"
  show "\<not> (x \<sim> z)"
  proof
    assume "x \<sim> z"
    also from `y \<sim> z` have "z \<sim> y" ..
    finally have "x \<sim> y" .
    with `\<not> (x \<sim> y)` show False by contradiction
  qed
qed

lemma not_equiv_trans2 [trans]: "x \<sim> y ==> \<not> (y \<sim> z) ==> \<not> (x \<sim> (z::'a::equiv))"
proof -
  assume "\<not> (y \<sim> z)" then have "\<not> (z \<sim> y)" ..
  also assume "x \<sim> y" then have "y \<sim> x" ..
  finally have "\<not> (z \<sim> x)" . then show "(\<not> x \<sim> z)" ..
qed

text {*
 \medskip The quotient type @{text "'a quot"} consists of all
 \emph{equivalence classes} over elements of the base type @{typ 'a}.
*}

definition "quot = {{x. a \<sim> x} | a::'a::eqv. True}"

typedef 'a quot = "quot :: 'a::eqv set set"
  unfolding quot_def by blast

lemma quotI [intro]: "{x. a \<sim> x} \<in> quot"
  unfolding quot_def by blast

lemma quotE [elim]: "R \<in> quot ==> (!!a. R = {x. a \<sim> x} ==> C) ==> C"
  unfolding quot_def by blast

text {*
 \medskip Abstracted equivalence classes are the canonical
 representation of elements of a quotient type.
*}

definition
  "class" :: "'a::equiv => 'a quot"  ("\<lfloor>_\<rfloor>") where
  "\<lfloor>a\<rfloor> = Abs_quot {x. a \<sim> x}"

theorem quot_exhaust: "\<exists>a. A = \<lfloor>a\<rfloor>"
proof (cases A)
  fix R assume R: "A = Abs_quot R"
  assume "R \<in> quot" then have "\<exists>a. R = {x. a \<sim> x}" by blast
  with R have "\<exists>a. A = Abs_quot {x. a \<sim> x}" by blast
  then show ?thesis unfolding class_def .
qed

lemma quot_cases [cases type: quot]: "(!!a. A = \<lfloor>a\<rfloor> ==> C) ==> C"
  using quot_exhaust by blast

subsection {* Equality on quotients *}

text {*
 Equality of canonical quotient elements coincides with the original
 relation.
*}

theorem quot_equality [iff?]: "(\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>) = (a \<sim> b)"
proof
  assume eq: "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>"
  show "a \<sim> b"
  proof -
    from eq have "{x. a \<sim> x} = {x. b \<sim> x}"
      by (simp only: class_def Abs_quot_inject quotI)
    moreover have "a \<sim> a" ..
    ultimately have "a \<in> {x. b \<sim> x}" by blast
    then have "b \<sim> a" by blast
    then show ?thesis ..
  qed
next
  assume ab: "a \<sim> b"
  show "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>"
  proof -
    have "{x. a \<sim> x} = {x. b \<sim> x}"
    proof (rule Collect_cong)
      fix x show "(a \<sim> x) = (b \<sim> x)"
      proof
        from ab have "b \<sim> a" ..
        also assume "a \<sim> x"
        finally show "b \<sim> x" .
      next
        note ab
        also assume "b \<sim> x"
        finally show "a \<sim> x" .
      qed
    qed
    then show ?thesis by (simp only: class_def)
  qed
qed

subsection {* Picking representing elements *}

definition
  pick :: "'a::equiv quot => 'a" where
  "pick A = (SOME a. A = \<lfloor>a\<rfloor>)"

theorem pick_equiv [intro]: "pick \<lfloor>a\<rfloor> \<sim> a"
proof (unfold pick_def)
  show "(SOME x. \<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>) \<sim> a"
  proof (rule someI2)
    show "\<lfloor>a\<rfloor> = \<lfloor>a\<rfloor>" ..
    fix x assume "\<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>"
    then have "a \<sim> x" .. then show "x \<sim> a" ..
  qed
qed

theorem pick_inverse [intro]: "\<lfloor>pick A\<rfloor> = A"
proof (cases A)
  fix a assume a: "A = \<lfloor>a\<rfloor>"
  then have "pick A \<sim> a" by (simp only: pick_equiv)
  then have "\<lfloor>pick A\<rfloor> = \<lfloor>a\<rfloor>" ..
  with a show ?thesis by simp
qed

text {*
 \medskip The following rules support canonical function definitions
 on quotient types (with up to two arguments).  Note that the
 stripped-down version without additional conditions is sufficient
 most of the time.
*}

theorem quot_cond_function:
  assumes eq: "!!X Y. P X Y ==> f X Y == g (pick X) (pick Y)"
    and cong: "!!x x' y y'. \<lfloor>x\<rfloor> = \<lfloor>x'\<rfloor> ==> \<lfloor>y\<rfloor> = \<lfloor>y'\<rfloor>
      ==> P \<lfloor>x\<rfloor> \<lfloor>y\<rfloor> ==> P \<lfloor>x'\<rfloor> \<lfloor>y'\<rfloor> ==> g x y = g x' y'"
    and P: "P \<lfloor>a\<rfloor> \<lfloor>b\<rfloor>"
  shows "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
proof -
  from eq and P have "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g (pick \<lfloor>a\<rfloor>) (pick \<lfloor>b\<rfloor>)" by (simp only:)
  also have "... = g a b"
  proof (rule cong)
    show "\<lfloor>pick \<lfloor>a\<rfloor>\<rfloor> = \<lfloor>a\<rfloor>" ..
    moreover
    show "\<lfloor>pick \<lfloor>b\<rfloor>\<rfloor> = \<lfloor>b\<rfloor>" ..
    moreover
    show "P \<lfloor>a\<rfloor> \<lfloor>b\<rfloor>" by (rule P)
    ultimately show "P \<lfloor>pick \<lfloor>a\<rfloor>\<rfloor> \<lfloor>pick \<lfloor>b\<rfloor>\<rfloor>" by (simp only:)
  qed
  finally show ?thesis .
qed

theorem quot_function:
  assumes "!!X Y. f X Y == g (pick X) (pick Y)"
    and "!!x x' y y'. \<lfloor>x\<rfloor> = \<lfloor>x'\<rfloor> ==> \<lfloor>y\<rfloor> = \<lfloor>y'\<rfloor> ==> g x y = g x' y'"
  shows "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
  using assms and TrueI
  by (rule quot_cond_function)

theorem quot_function':
  "(!!X Y. f X Y == g (pick X) (pick Y)) ==>
    (!!x x' y y'. x \<sim> x' ==> y \<sim> y' ==> g x y = g x' y') ==>
    f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
  by (rule quot_function) (simp_all only: quot_equality)

end