111 |
111 |
112 rep_datatype nat |
112 rep_datatype nat |
113 distinct Suc_not_Zero Zero_not_Suc |
113 distinct Suc_not_Zero Zero_not_Suc |
114 inject Suc_Suc_eq |
114 inject Suc_Suc_eq |
115 induction nat_induct [case_names 0 Suc] |
115 induction nat_induct [case_names 0 Suc] |
|
116 |
|
117 text {* fix syntax translation for nat case *} |
|
118 |
|
119 setup {* |
|
120 let |
|
121 val thy = the_context (); |
|
122 val info = DatatypePackage.the_datatype thy "nat"; |
|
123 val constrs = (#3 o snd o hd o #descr) info; |
|
124 val constrs' = ["0", "Suc"]; |
|
125 val case_name = Sign.extern_const thy (#case_name info); |
|
126 fun nat_case_tr' context ts = |
|
127 if length ts <> length constrs + 1 then raise Match else |
|
128 let |
|
129 val (fs, x) = split_last ts; |
|
130 fun strip_abs 0 t = ([], t) |
|
131 | strip_abs i (Abs p) = |
|
132 let val (x, u) = Syntax.atomic_abs_tr' p |
|
133 in apfst (cons x) (strip_abs (i-1) u) end |
|
134 | strip_abs i (Const ("split", _) $ t) = (case strip_abs (i+1) t of |
|
135 (v :: v' :: vs, u) => (Syntax.const "Pair" $ v $ v' :: vs, u)); |
|
136 fun is_dependent i t = |
|
137 let val k = length (strip_abs_vars t) - i |
|
138 in k < 0 orelse exists (fn j => j >= k) |
|
139 (loose_bnos (strip_abs_body t)) |
|
140 end; |
|
141 val cases = map (fn (((cname, dts), cname'), t) => |
|
142 (cname', strip_abs (length dts) t, is_dependent (length dts) t)) |
|
143 (constrs ~~ constrs' ~~ fs); |
|
144 fun count_cases (_, _, true) = I |
|
145 | count_cases (cname, (_, body), false) = |
|
146 AList.map_default (op = : term * term -> bool) |
|
147 (body, []) (cons cname) |
|
148 val cases' = sort (int_ord o swap o pairself (length o snd)) |
|
149 (fold_rev count_cases cases []); |
|
150 fun mk_case1 (cname, (vs, body), _) = Syntax.const "_case1" $ |
|
151 list_comb (Syntax.const cname, vs) $ body; |
|
152 fun is_undefined (Const ("undefined", _)) = true |
|
153 | is_undefined _ = false; |
|
154 in |
|
155 Syntax.const "_case_syntax" $ x $ |
|
156 foldr1 (fn (t, u) => Syntax.const "_case2" $ t $ u) (map mk_case1 |
|
157 (case find_first (is_undefined o fst) cases' of |
|
158 SOME (_, cnames) => |
|
159 if length cnames = length constrs then [hd cases] |
|
160 else filter_out (fn (_, (_, body), _) => is_undefined body) cases |
|
161 | NONE => case cases' of |
|
162 [] => cases |
|
163 | (default, cnames) :: _ => |
|
164 if length cnames = 1 then cases |
|
165 else if length cnames = length constrs then |
|
166 [hd cases, ("dummy_pattern", ([], default), false)] |
|
167 else |
|
168 filter_out (fn (cname, _, _) => cname mem cnames) cases @ |
|
169 [("dummy_pattern", ([], default), false)])) |
|
170 end |
|
171 in |
|
172 Theory.add_advanced_trfuns ([], [], [(case_name, nat_case_tr')], []) |
|
173 end |
|
174 *} |
116 |
175 |
117 lemma n_not_Suc_n: "n \<noteq> Suc n" |
176 lemma n_not_Suc_n: "n \<noteq> Suc n" |
118 by (induct n) simp_all |
177 by (induct n) simp_all |
119 |
178 |
120 lemma Suc_n_not_n: "Suc t \<noteq> t" |
179 lemma Suc_n_not_n: "Suc t \<noteq> t" |
1081 "op + \<Colon> nat \<Rightarrow> nat \<Rightarrow> nat" "IntDef.plus_nat" |
1140 "op + \<Colon> nat \<Rightarrow> nat \<Rightarrow> nat" "IntDef.plus_nat" |
1082 "op - \<Colon> nat \<Rightarrow> nat \<Rightarrow> nat" "IntDef.minus_nat" |
1141 "op - \<Colon> nat \<Rightarrow> nat \<Rightarrow> nat" "IntDef.minus_nat" |
1083 "op * \<Colon> nat \<Rightarrow> nat \<Rightarrow> nat" "IntDef.times_nat" |
1142 "op * \<Colon> nat \<Rightarrow> nat \<Rightarrow> nat" "IntDef.times_nat" |
1084 "op < \<Colon> nat \<Rightarrow> nat \<Rightarrow> bool" "IntDef.less_nat" |
1143 "op < \<Colon> nat \<Rightarrow> nat \<Rightarrow> bool" "IntDef.less_nat" |
1085 "op \<le> \<Colon> nat \<Rightarrow> nat \<Rightarrow> bool" "IntDef.less_eq_nat" |
1144 "op \<le> \<Colon> nat \<Rightarrow> nat \<Rightarrow> bool" "IntDef.less_eq_nat" |
1086 "OperationalEquality.eq \<Colon> nat \<Rightarrow> nat \<Rightarrow> bool" "IntDef.eq_nat" |
1145 "Code_Generator.eq \<Colon> nat \<Rightarrow> nat \<Rightarrow> bool" "IntDef.eq_nat" |
1087 nat_rec "IntDef.nat_rec" |
1146 nat_rec "IntDef.nat_rec" |
1088 nat_case "IntDef.nat_case" |
1147 nat_case "IntDef.nat_case" |
1089 |
1148 |
1090 end |
1149 end |