src/HOL/Tools/inductive_realizer.ML
changeset 46219 426ed18eba43
parent 45839 43a5b86bc102
child 46708 b138dee7bed3
equal deleted inserted replaced
46218:ecf6375e2abb 46219:426ed18eba43
    86           val i = length Ts;
    86           val i = length Ts;
    87           val xs = map (pair "x") Ts;
    87           val xs = map (pair "x") Ts;
    88           val u = list_comb (t, map Bound (i - 1 downto 0))
    88           val u = list_comb (t, map Bound (i - 1 downto 0))
    89         in 
    89         in 
    90           if member (op =) vs a then
    90           if member (op =) vs a then
    91             list_abs (("r", U) :: xs, mk_rlz U $ Bound i $ u)
    91             fold_rev Term.abs (("r", U) :: xs) (mk_rlz U $ Bound i $ u)
    92           else list_abs (xs, mk_rlz Extraction.nullT $ Extraction.nullt $ u)
    92           else
       
    93             fold_rev Term.abs xs (mk_rlz Extraction.nullT $ Extraction.nullt $ u)
    93         end
    94         end
    94   | gen_rvar _ t = t;
    95   | gen_rvar _ t = t;
    95 
    96 
    96 fun mk_realizes_eqn n vs nparms intrs =
    97 fun mk_realizes_eqn n vs nparms intrs =
    97   let
    98   let
   162             else if is_rec prem then
   163             else if is_rec prem then
   163               if is_meta prem then
   164               if is_meta prem then
   164                 let
   165                 let
   165                   val prem' :: prems' = prems;
   166                   val prem' :: prems' = prems;
   166                   val U = Extraction.etype_of thy vs [] prem';
   167                   val U = Extraction.etype_of thy vs [] prem';
   167                 in if U = Extraction.nullT
   168                 in
       
   169                   if U = Extraction.nullT
   168                   then fun_of (Free (x, T) :: ts)
   170                   then fun_of (Free (x, T) :: ts)
   169                     (Free (r, binder_types T ---> HOLogic.unitT) :: rts)
   171                     (Free (r, binder_types T ---> HOLogic.unitT) :: rts)
   170                     (Free (x, T) :: args) (x :: r :: used) prems'
   172                     (Free (x, T) :: args) (x :: r :: used) prems'
   171                   else fun_of (Free (x, T) :: ts) (Free (r, U) :: rts)
   173                   else fun_of (Free (x, T) :: ts) (Free (r, U) :: rts)
   172                     (Free (r, U) :: Free (x, T) :: args) (x :: r :: used) prems'
   174                     (Free (r, U) :: Free (x, T) :: args) (x :: r :: used) prems'
   173                 end
   175                 end
   174               else (case strip_type T of
   176               else
       
   177                 (case strip_type T of
   175                   (Ts, Type (@{type_name Product_Type.prod}, [T1, T2])) =>
   178                   (Ts, Type (@{type_name Product_Type.prod}, [T1, T2])) =>
   176                     let
   179                     let
   177                       val fx = Free (x, Ts ---> T1);
   180                       val fx = Free (x, Ts ---> T1);
   178                       val fr = Free (r, Ts ---> T2);
   181                       val fr = Free (r, Ts ---> T2);
   179                       val bs = map Bound (length Ts - 1 downto 0);
   182                       val bs = map Bound (length Ts - 1 downto 0);
   180                       val t = list_abs (map (pair "z") Ts,
   183                       val t =
   181                         HOLogic.mk_prod (list_comb (fx, bs), list_comb (fr, bs)))
   184                         fold_rev (Term.abs o pair "z") Ts
   182                     in fun_of (fx :: ts) (fr :: rts) (t::args)
   185                           (HOLogic.mk_prod (list_comb (fx, bs), list_comb (fr, bs)));
   183                       (x :: r :: used) prems
   186                     in fun_of (fx :: ts) (fr :: rts) (t::args) (x :: r :: used) prems end
   184                     end
       
   185                 | (Ts, U) => fun_of (Free (x, T) :: ts)
   187                 | (Ts, U) => fun_of (Free (x, T) :: ts)
   186                     (Free (r, binder_types T ---> HOLogic.unitT) :: rts)
   188                     (Free (r, binder_types T ---> HOLogic.unitT) :: rts)
   187                     (Free (x, T) :: args) (x :: r :: used) prems)
   189                     (Free (x, T) :: args) (x :: r :: used) prems)
   188             else fun_of (Free (x, T) :: ts) rts (Free (x, T) :: args)
   190             else fun_of (Free (x, T) :: ts) rts (Free (x, T) :: args)
   189               (x :: used) prems
   191               (x :: used) prems
   437         val p = Logic.list_implies
   439         val p = Logic.list_implies
   438           (map reorder1 (prems ~~ intrs) @ [prem], concl_of elim);
   440           (map reorder1 (prems ~~ intrs) @ [prem], concl_of elim);
   439         val T' = Extraction.etype_of thy (vs @ Ps) [] p;
   441         val T' = Extraction.etype_of thy (vs @ Ps) [] p;
   440         val T = if dummy then (HOLogic.unitT --> body_type T') --> T' else T';
   442         val T = if dummy then (HOLogic.unitT --> body_type T') --> T' else T';
   441         val Ts = map (Extraction.etype_of thy (vs @ Ps) []) (prems_of elim);
   443         val Ts = map (Extraction.etype_of thy (vs @ Ps) []) (prems_of elim);
   442         val r = if null Ps then Extraction.nullt
   444         val r =
   443           else list_abs (map (pair "x") Ts, list_comb (Const (case_name, T),
   445           if null Ps then Extraction.nullt
   444             (if dummy then
   446           else
   445                [Abs ("x", HOLogic.unitT, Const (@{const_name default}, body_type T))]
   447             fold_rev (Term.abs o pair "x") Ts
   446              else []) @
   448               (list_comb (Const (case_name, T),
   447             map reorder2 (intrs ~~ (length prems - 1 downto 0)) @
   449                 (if dummy then
   448             [Bound (length prems)]));
   450                    [Abs ("x", HOLogic.unitT, Const (@{const_name default}, body_type T))]
       
   451                  else []) @
       
   452                 map reorder2 (intrs ~~ (length prems - 1 downto 0)) @
       
   453                 [Bound (length prems)]));
   449         val rlz = Extraction.realizes_of thy (vs @ Ps) r (prop_of elim);
   454         val rlz = Extraction.realizes_of thy (vs @ Ps) r (prop_of elim);
   450         val rlz' = attach_typeS (strip_all (Logic.unvarify_global rlz));
   455         val rlz' = attach_typeS (strip_all (Logic.unvarify_global rlz));
   451         val rews = map mk_meta_eq case_thms;
   456         val rews = map mk_meta_eq case_thms;
   452         val thm = Goal.prove_global thy []
   457         val thm = Goal.prove_global thy []
   453           (Logic.strip_imp_prems rlz') (Logic.strip_imp_concl rlz') (fn {prems, ...} => EVERY
   458           (Logic.strip_imp_prems rlz') (Logic.strip_imp_concl rlz') (fn {prems, ...} => EVERY