src/HOL/Tools/Function/termination.ML
changeset 60328 9c94e6a30d29
parent 59970 e9f73d87d904
child 60752 b48830b670a1
equal deleted inserted replaced
60327:a3f565b8ba76 60328:9c94e6a30d29
   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