140 val goal = |
140 val goal = |
141 HOLogic.mk_eq (HOLogic.mk_binop @{const_name Relation.relcomp} (c1, c2), |
141 HOLogic.mk_eq (HOLogic.mk_binop @{const_name Relation.relcomp} (c1, c2), |
142 Const (@{const_abbrev Set.empty}, fastype_of c1)) |
142 Const (@{const_abbrev Set.empty}, fastype_of c1)) |
143 |> HOLogic.mk_Trueprop (* "C1 O C2 = {}" *) |
143 |> HOLogic.mk_Trueprop (* "C1 O C2 = {}" *) |
144 in |
144 in |
145 case Function_Lib.try_proof (Thm.cterm_of ctxt goal) chain_tac of |
145 (case Function_Lib.try_proof ctxt (Thm.cterm_of ctxt goal) chain_tac of |
146 Function_Lib.Solved thm => SOME thm |
146 Function_Lib.Solved thm => SOME thm |
147 | _ => NONE |
147 | _ => NONE) |
148 end |
148 end |
149 |
149 |
150 |
150 |
151 fun dest_call' sk (Const (@{const_name Collect}, _) $ Abs (_, _, c)) = |
151 fun dest_call' sk (Const (@{const_name Collect}, _) $ Abs (_, _, c)) = |
152 let |
152 let |
165 fun dest_call (sk, _, _, _, _) = dest_call' sk |
165 fun dest_call (sk, _, _, _, _) = dest_call' sk |
166 |
166 |
167 fun mk_desc ctxt tac vs Gam l r m1 m2 = |
167 fun mk_desc ctxt tac vs Gam l r m1 m2 = |
168 let |
168 let |
169 fun try rel = |
169 fun try rel = |
170 try_proof (Thm.cterm_of ctxt |
170 try_proof ctxt (Thm.cterm_of ctxt |
171 (Logic.list_all (vs, |
171 (Logic.list_all (vs, |
172 Logic.mk_implies (HOLogic.mk_Trueprop Gam, |
172 Logic.mk_implies (HOLogic.mk_Trueprop Gam, |
173 HOLogic.mk_Trueprop (Const (rel, @{typ "nat => nat => bool"}) |
173 HOLogic.mk_Trueprop (Const (rel, @{typ "nat \<Rightarrow> nat \<Rightarrow> bool"}) |
174 $ (m2 $ r) $ (m1 $ l)))))) tac |
174 $ (m2 $ r) $ (m1 $ l)))))) tac |
175 in |
175 in |
176 case try @{const_name Orderings.less} of |
176 (case try @{const_name Orderings.less} of |
177 Solved thm => Less thm |
177 Solved thm => Less thm |
178 | Stuck thm => |
178 | Stuck thm => |
179 (case try @{const_name Orderings.less_eq} of |
179 (case try @{const_name Orderings.less_eq} of |
180 Solved thm2 => LessEq (thm2, thm) |
180 Solved thm2 => LessEq (thm2, thm) |
181 | Stuck thm2 => |
181 | Stuck thm2 => |
182 if Thm.prems_of thm2 = [HOLogic.Trueprop $ @{term False}] |
182 if Thm.prems_of thm2 = [HOLogic.Trueprop $ @{term False}] |
183 then False thm2 else None (thm2, thm) |
183 then False thm2 else None (thm2, thm) |
184 | _ => raise Match) (* FIXME *) |
184 | _ => raise Match) (* FIXME *) |
185 | _ => raise Match |
185 | _ => raise Match) |
186 end |
186 end |
187 |
187 |
188 fun prove_descent ctxt tac sk (c, (m1, m2)) = |
188 fun prove_descent ctxt tac sk (c, (m1, m2)) = |
189 let |
189 let |
190 val (vs, _, l, _, r, Gam) = dest_call' sk c |
190 val (vs, _, l, _, r, Gam) = dest_call' sk c |