src/HOL/Quotient_Examples/Lift_RBT.thy
changeset 47092 fa3538d6004b
parent 46133 d9fe85d3d2cd
child 47093 0516a6c1ea59
equal deleted inserted replaced
47091:d5cd13aca90b 47092:fa3538d6004b
    16 qed
    16 qed
    17 
    17 
    18 local_setup {* fn lthy =>
    18 local_setup {* fn lthy =>
    19 let
    19 let
    20   val quotients = {qtyp = @{typ "('a, 'b) rbt"}, rtyp = @{typ "('a, 'b) RBT_Impl.rbt"},
    20   val quotients = {qtyp = @{typ "('a, 'b) rbt"}, rtyp = @{typ "('a, 'b) RBT_Impl.rbt"},
    21     equiv_rel = @{term "dummy"}, equiv_thm = @{thm refl}}
    21     equiv_rel = @{term "op ="}, equiv_thm = @{thm refl}}
    22   val qty_full_name = @{type_name "rbt"}
    22   val qty_full_name = @{type_name "rbt"}
    23 
    23 
    24   fun qinfo phi = Quotient_Info.transform_quotients phi quotients
    24   fun qinfo phi = Quotient_Info.transform_quotients phi quotients
    25   in lthy
    25   in lthy
    26     |> Local_Theory.declaration {syntax = false, pervasive = true}
    26     |> Local_Theory.declaration {syntax = false, pervasive = true}
    48 
    48 
    49 
    49 
    50 subsection {* Primitive operations *}
    50 subsection {* Primitive operations *}
    51 
    51 
    52 quotient_definition lookup where "lookup :: ('a\<Colon>linorder, 'b) rbt \<Rightarrow> 'a \<rightharpoonup> 'b" is "RBT_Impl.lookup"
    52 quotient_definition lookup where "lookup :: ('a\<Colon>linorder, 'b) rbt \<Rightarrow> 'a \<rightharpoonup> 'b" is "RBT_Impl.lookup"
       
    53 done
    53 
    54 
    54 declare lookup_def[unfolded map_fun_def comp_def id_def, code]
    55 declare lookup_def[unfolded map_fun_def comp_def id_def, code]
    55 
    56 
    56 (* FIXME: quotient_definition at the moment requires that types variables match exactly,
    57 (* FIXME: quotient_definition at the moment requires that types variables match exactly,
    57 i.e., sort constraints must be annotated to the constant being lifted.
    58 i.e., sort constraints must be annotated to the constant being lifted.
    65 
    66 
    66 Similar issue for quotient_definition for entries, keys, map, and fold.
    67 Similar issue for quotient_definition for entries, keys, map, and fold.
    67 *)
    68 *)
    68 
    69 
    69 quotient_definition empty where "empty :: ('a\<Colon>linorder, 'b) rbt"
    70 quotient_definition empty where "empty :: ('a\<Colon>linorder, 'b) rbt"
    70 is "(RBT_Impl.Empty :: ('a\<Colon>linorder, 'b) RBT_Impl.rbt)"
    71 is "(RBT_Impl.Empty :: ('a\<Colon>linorder, 'b) RBT_Impl.rbt)" done
    71 
    72 
    72 lemma impl_of_empty [code abstract]:
    73 lemma impl_of_empty [code abstract]:
    73   "impl_of empty = RBT_Impl.Empty"
    74   "impl_of empty = RBT_Impl.Empty"
    74   by (simp add: empty_def RBT_inverse)
    75   by (simp add: empty_def RBT_inverse)
    75 
    76 
    76 quotient_definition insert where "insert :: 'a\<Colon>linorder \<Rightarrow> 'b \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
    77 quotient_definition insert where "insert :: 'a\<Colon>linorder \<Rightarrow> 'b \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
    77 is "RBT_Impl.insert"
    78 is "RBT_Impl.insert" done
    78 
    79 
    79 lemma impl_of_insert [code abstract]:
    80 lemma impl_of_insert [code abstract]:
    80   "impl_of (insert k v t) = RBT_Impl.insert k v (impl_of t)"
    81   "impl_of (insert k v t) = RBT_Impl.insert k v (impl_of t)"
    81   by (simp add: insert_def RBT_inverse)
    82   by (simp add: insert_def RBT_inverse)
    82 
    83 
    83 quotient_definition delete where "delete :: 'a\<Colon>linorder \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
    84 quotient_definition delete where "delete :: 'a\<Colon>linorder \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
    84 is "RBT_Impl.delete"
    85 is "RBT_Impl.delete" done
    85 
    86 
    86 lemma impl_of_delete [code abstract]:
    87 lemma impl_of_delete [code abstract]:
    87   "impl_of (delete k t) = RBT_Impl.delete k (impl_of t)"
    88   "impl_of (delete k t) = RBT_Impl.delete k (impl_of t)"
    88   by (simp add: delete_def RBT_inverse)
    89   by (simp add: delete_def RBT_inverse)
    89 
    90 
    90 (* FIXME: unnecessary type annotations *)
    91 (* FIXME: unnecessary type annotations *)
    91 quotient_definition "entries :: ('a\<Colon>linorder, 'b) rbt \<Rightarrow> ('a \<times> 'b) list"
    92 quotient_definition "entries :: ('a\<Colon>linorder, 'b) rbt \<Rightarrow> ('a \<times> 'b) list"
    92 is "RBT_Impl.entries :: ('a\<Colon>linorder, 'b) RBT_Impl.rbt \<Rightarrow> ('a \<times> 'b) list"
    93 is "RBT_Impl.entries :: ('a\<Colon>linorder, 'b) RBT_Impl.rbt \<Rightarrow> ('a \<times> 'b) list" done
    93 
    94 
    94 lemma [code]: "entries t = RBT_Impl.entries (impl_of t)"
    95 lemma [code]: "entries t = RBT_Impl.entries (impl_of t)"
    95 unfolding entries_def map_fun_def comp_def id_def ..
    96 unfolding entries_def map_fun_def comp_def id_def ..
    96 
    97 
    97 (* FIXME: unnecessary type annotations *)
    98 (* FIXME: unnecessary type annotations *)
    98 quotient_definition "keys :: ('a\<Colon>linorder, 'b) rbt \<Rightarrow> 'a list"
    99 quotient_definition "keys :: ('a\<Colon>linorder, 'b) rbt \<Rightarrow> 'a list"
    99 is "RBT_Impl.keys :: ('a\<Colon>linorder, 'b) RBT_Impl.rbt \<Rightarrow> 'a list"
   100 is "RBT_Impl.keys :: ('a\<Colon>linorder, 'b) RBT_Impl.rbt \<Rightarrow> 'a list" done
   100 
   101 
   101 quotient_definition "bulkload :: ('a\<Colon>linorder \<times> 'b) list \<Rightarrow> ('a, 'b) rbt"
   102 quotient_definition "bulkload :: ('a\<Colon>linorder \<times> 'b) list \<Rightarrow> ('a, 'b) rbt"
   102 is "RBT_Impl.bulkload"
   103 is "RBT_Impl.bulkload" done
   103 
   104 
   104 lemma impl_of_bulkload [code abstract]:
   105 lemma impl_of_bulkload [code abstract]:
   105   "impl_of (bulkload xs) = RBT_Impl.bulkload xs"
   106   "impl_of (bulkload xs) = RBT_Impl.bulkload xs"
   106   by (simp add: bulkload_def RBT_inverse)
   107   by (simp add: bulkload_def RBT_inverse)
   107 
   108 
   108 quotient_definition "map_entry :: 'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a\<Colon>linorder, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
   109 quotient_definition "map_entry :: 'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a\<Colon>linorder, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
   109 is "RBT_Impl.map_entry"
   110 is "RBT_Impl.map_entry" done
   110 
   111 
   111 lemma impl_of_map_entry [code abstract]:
   112 lemma impl_of_map_entry [code abstract]:
   112   "impl_of (map_entry k f t) = RBT_Impl.map_entry k f (impl_of t)"
   113   "impl_of (map_entry k f t) = RBT_Impl.map_entry k f (impl_of t)"
   113   by (simp add: map_entry_def RBT_inverse)
   114   by (simp add: map_entry_def RBT_inverse)
   114 
   115 
   115 (* FIXME: unnecesary type annotations *)
   116 (* FIXME: unnecesary type annotations *)
   116 quotient_definition map where "map :: ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a\<Colon>linorder, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
   117 quotient_definition map where "map :: ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a\<Colon>linorder, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
   117 is "RBT_Impl.map :: ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a\<Colon>linorder, 'b) RBT_Impl.rbt \<Rightarrow> ('a, 'b) RBT_Impl.rbt"
   118 is "RBT_Impl.map :: ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a\<Colon>linorder, 'b) RBT_Impl.rbt \<Rightarrow> ('a, 'b) RBT_Impl.rbt"
       
   119 done
   118 
   120 
   119 lemma impl_of_map [code abstract]:
   121 lemma impl_of_map [code abstract]:
   120   "impl_of (map f t) = RBT_Impl.map f (impl_of t)"
   122   "impl_of (map f t) = RBT_Impl.map f (impl_of t)"
   121   by (simp add: map_def RBT_inverse)
   123   by (simp add: map_def RBT_inverse)
   122 
   124 
   123 (* FIXME: unnecessary type annotations *)
   125 (* FIXME: unnecessary type annotations *)
   124 quotient_definition fold where "fold :: ('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> ('a\<Colon>linorder, 'b) rbt \<Rightarrow> 'c \<Rightarrow> 'c" is "RBT_Impl.fold :: ('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> ('a\<Colon>linorder, 'b) RBT_Impl.rbt \<Rightarrow> 'c \<Rightarrow> 'c"
   126 quotient_definition fold where "fold :: ('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> ('a\<Colon>linorder, 'b) rbt \<Rightarrow> 'c \<Rightarrow> 'c" 
       
   127 is "RBT_Impl.fold :: ('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> ('a\<Colon>linorder, 'b) RBT_Impl.rbt \<Rightarrow> 'c \<Rightarrow> 'c" done
   125 
   128 
   126 lemma [code]: "fold f t = RBT_Impl.fold f (impl_of t)"
   129 lemma [code]: "fold f t = RBT_Impl.fold f (impl_of t)"
   127 unfolding fold_def map_fun_def comp_def id_def ..
   130 unfolding fold_def map_fun_def comp_def id_def ..
   128 
   131 
   129 
   132