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)" |