src/HOL/HOL.thy
changeset 38857 97775f3e8722
parent 38795 848be46708dc
child 38864 4abe644fcea5
equal deleted inserted replaced
38856:168dba35ecf3 38857:97775f3e8722
  1773   #> Code_Simp.map_ss (K HOL_basic_ss)
  1773   #> Code_Simp.map_ss (K HOL_basic_ss)
  1774 *}
  1774 *}
  1775 
  1775 
  1776 subsubsection {* Equality *}
  1776 subsubsection {* Equality *}
  1777 
  1777 
  1778 class eq =
  1778 class equal =
  1779   fixes eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  1779   fixes equal :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  1780   assumes eq_equals: "eq x y \<longleftrightarrow> x = y"
  1780   assumes equal_eq: "equal x y \<longleftrightarrow> x = y"
  1781 begin
  1781 begin
  1782 
  1782 
  1783 lemma eq [code_unfold, code_inline del]: "eq = (op =)"
  1783 lemma equal [code_unfold, code_inline del]: "equal = (op =)"
  1784   by (rule ext eq_equals)+
  1784   by (rule ext equal_eq)+
  1785 
  1785 
  1786 lemma eq_refl: "eq x x \<longleftrightarrow> True"
  1786 lemma equal_refl: "equal x x \<longleftrightarrow> True"
  1787   unfolding eq by rule+
  1787   unfolding equal by rule+
  1788 
  1788 
  1789 lemma equals_eq: "(op =) \<equiv> eq"
  1789 lemma eq_equal: "(op =) \<equiv> equal"
  1790   by (rule eq_reflection) (rule ext, rule ext, rule sym, rule eq_equals)
  1790   by (rule eq_reflection) (rule ext, rule ext, rule sym, rule equal_eq)
  1791 
       
  1792 declare equals_eq [symmetric, code_post]
       
  1793 
  1791 
  1794 end
  1792 end
  1795 
  1793 
  1796 declare equals_eq [code]
  1794 declare eq_equal [symmetric, code_post]
       
  1795 declare eq_equal [code]
  1797 
  1796 
  1798 setup {*
  1797 setup {*
  1799   Code_Preproc.map_pre (fn simpset =>
  1798   Code_Preproc.map_pre (fn simpset =>
  1800     simpset addsimprocs [Simplifier.simproc_global_i @{theory} "eq" [@{term "op ="}]
  1799     simpset addsimprocs [Simplifier.simproc_global_i @{theory} "equal" [@{term "op ="}]
  1801       (fn thy => fn _ => fn Const (_, T) => case strip_type T
  1800       (fn thy => fn _ => fn Const (_, T) => case strip_type T
  1802         of (Type _ :: _, _) => SOME @{thm equals_eq}
  1801         of (Type _ :: _, _) => SOME @{thm eq_equal}
  1803          | _ => NONE)])
  1802          | _ => NONE)])
  1804 *}
  1803 *}
  1805 
  1804 
  1806 
  1805 
  1807 subsubsection {* Generic code generator foundation *}
  1806 subsubsection {* Generic code generator foundation *}
  1837   shows "(False \<longrightarrow> P) \<longleftrightarrow> True"
  1836   shows "(False \<longrightarrow> P) \<longleftrightarrow> True"
  1838     and "(True \<longrightarrow> P) \<longleftrightarrow> P"
  1837     and "(True \<longrightarrow> P) \<longleftrightarrow> P"
  1839     and "(P \<longrightarrow> False) \<longleftrightarrow> \<not> P"
  1838     and "(P \<longrightarrow> False) \<longleftrightarrow> \<not> P"
  1840     and "(P \<longrightarrow> True) \<longleftrightarrow> True" by simp_all
  1839     and "(P \<longrightarrow> True) \<longleftrightarrow> True" by simp_all
  1841 
  1840 
  1842 instantiation itself :: (type) eq
  1841 instantiation itself :: (type) equal
  1843 begin
  1842 begin
  1844 
  1843 
  1845 definition eq_itself :: "'a itself \<Rightarrow> 'a itself \<Rightarrow> bool" where
  1844 definition equal_itself :: "'a itself \<Rightarrow> 'a itself \<Rightarrow> bool" where
  1846   "eq_itself x y \<longleftrightarrow> x = y"
  1845   "equal_itself x y \<longleftrightarrow> x = y"
  1847 
  1846 
  1848 instance proof
  1847 instance proof
  1849 qed (fact eq_itself_def)
  1848 qed (fact equal_itself_def)
  1850 
  1849 
  1851 end
  1850 end
  1852 
  1851 
  1853 lemma eq_itself_code [code]:
  1852 lemma equal_itself_code [code]:
  1854   "eq_class.eq TYPE('a) TYPE('a) \<longleftrightarrow> True"
  1853   "equal TYPE('a) TYPE('a) \<longleftrightarrow> True"
  1855   by (simp add: eq)
  1854   by (simp add: equal)
  1856 
  1855 
  1857 text {* Equality *}
  1856 text {* Equality *}
  1858 
  1857 
  1859 declare simp_thms(6) [code nbe]
  1858 declare simp_thms(6) [code nbe]
  1860 
  1859 
  1861 setup {*
  1860 setup {*
  1862   Sign.add_const_constraint (@{const_name eq}, SOME @{typ "'a\<Colon>type \<Rightarrow> 'a \<Rightarrow> bool"})
  1861   Sign.add_const_constraint (@{const_name equal}, SOME @{typ "'a\<Colon>type \<Rightarrow> 'a \<Rightarrow> bool"})
  1863 *}
  1862 *}
  1864 
  1863 
  1865 lemma equals_alias_cert: "OFCLASS('a, eq_class) \<equiv> ((op = :: 'a \<Rightarrow> 'a \<Rightarrow> bool) \<equiv> eq)" (is "?ofclass \<equiv> ?eq")
  1864 lemma equal_alias_cert: "OFCLASS('a, equal_class) \<equiv> ((op = :: 'a \<Rightarrow> 'a \<Rightarrow> bool) \<equiv> equal)" (is "?ofclass \<equiv> ?equal")
  1866 proof
  1865 proof
  1867   assume "PROP ?ofclass"
  1866   assume "PROP ?ofclass"
  1868   show "PROP ?eq"
  1867   show "PROP ?equal"
  1869     by (tactic {* ALLGOALS (rtac (Thm.unconstrainT @{thm equals_eq})) *})
  1868     by (tactic {* ALLGOALS (rtac (Thm.unconstrainT @{thm eq_equal})) *})
  1870       (fact `PROP ?ofclass`)
  1869       (fact `PROP ?ofclass`)
  1871 next
  1870 next
  1872   assume "PROP ?eq"
  1871   assume "PROP ?equal"
  1873   show "PROP ?ofclass" proof
  1872   show "PROP ?ofclass" proof
  1874   qed (simp add: `PROP ?eq`)
  1873   qed (simp add: `PROP ?equal`)
  1875 qed
  1874 qed
  1876   
  1875   
  1877 setup {*
  1876 setup {*
  1878   Sign.add_const_constraint (@{const_name eq}, SOME @{typ "'a\<Colon>eq \<Rightarrow> 'a \<Rightarrow> bool"})
  1877   Sign.add_const_constraint (@{const_name equal}, SOME @{typ "'a\<Colon>equal \<Rightarrow> 'a \<Rightarrow> bool"})
  1879 *}
  1878 *}
  1880 
  1879 
  1881 setup {*
  1880 setup {*
  1882   Nbe.add_const_alias @{thm equals_alias_cert}
  1881   Nbe.add_const_alias @{thm equal_alias_cert}
  1883 *}
  1882 *}
  1884 
  1883 
  1885 hide_const (open) eq
  1884 hide_const (open) equal
  1886 
  1885 
  1887 text {* Cases *}
  1886 text {* Cases *}
  1888 
  1887 
  1889 lemma Let_case_cert:
  1888 lemma Let_case_cert:
  1890   assumes "CASE \<equiv> (\<lambda>x. Let x f)"
  1889   assumes "CASE \<equiv> (\<lambda>x. Let x f)"
  1937 code_reserved Scala
  1936 code_reserved Scala
  1938   Boolean
  1937   Boolean
  1939 
  1938 
  1940 text {* using built-in Haskell equality *}
  1939 text {* using built-in Haskell equality *}
  1941 
  1940 
  1942 code_class eq
  1941 code_class equal
  1943   (Haskell "Eq")
  1942   (Haskell "Eq")
  1944 
  1943 
  1945 code_const "eq_class.eq"
  1944 code_const "HOL.equal"
  1946   (Haskell infixl 4 "==")
  1945   (Haskell infixl 4 "==")
  1947 
  1946 
  1948 code_const "op ="
  1947 code_const "op ="
  1949   (Haskell infixl 4 "==")
  1948   (Haskell infixl 4 "==")
  1950 
  1949