src/HOL/Tools/Function/function_lib.ML
changeset 40076 6f012a209dac
parent 39756 6c8e83d94536
child 40722 441260986b63
equal deleted inserted replaced
40075:1c75f3f192ae 40076:6f012a209dac
     6 *)
     6 *)
     7 
     7 
     8 structure Function_Lib =   (* FIXME proper signature *)
     8 structure Function_Lib =   (* FIXME proper signature *)
     9 struct
     9 struct
    10 
    10 
    11 fun map_option f NONE = NONE
    11 (* "The variable" ^ plural " is" "s are" vs *)
    12   | map_option f (SOME x) = SOME (f x);
       
    13 
       
    14 fun fold_option f NONE y = y
       
    15   | fold_option f (SOME x) y = f x y;
       
    16 
       
    17 (* Ex: "The variable" ^ plural " is" "s are" vs *)
       
    18 fun plural sg pl [x] = sg
    12 fun plural sg pl [x] = sg
    19   | plural sg pl _ = pl
    13   | plural sg pl _ = pl
    20 
       
    21 fun dest_all (Const ("all", _) $ Abs (a as (_,T,_))) =
       
    22   let
       
    23     val (n, body) = Term.dest_abs a
       
    24   in
       
    25     (Free (n, T), body)
       
    26   end
       
    27   | dest_all _ = raise Match
       
    28 
    14 
    29 
    15 
    30 (* Removes all quantifiers from a term, replacing bound variables by frees. *)
    16 (* Removes all quantifiers from a term, replacing bound variables by frees. *)
    31 fun dest_all_all (t as (Const ("all",_) $ _)) =
    17 fun dest_all_all (t as (Const ("all",_) $ _)) =
    32   let
    18   let
    33     val (v,b) = dest_all t
    19     val (v,b) = Logic.dest_all t |> apfst Free
    34     val (vs, b') = dest_all_all b
    20     val (vs, b') = dest_all_all b
    35   in
    21   in
    36     (v :: vs, b')
    22     (v :: vs, b')
    37   end
    23   end
    38   | dest_all_all t = ([],t)
    24   | dest_all_all t = ([],t)
    54   end
    40   end
    55   | dest_all_all_ctx ctx t =
    41   | dest_all_all_ctx ctx t =
    56   (ctx, [], t)
    42   (ctx, [], t)
    57 
    43 
    58 
    44 
    59 fun map3 _ [] [] [] = []
       
    60   | map3 f (x :: xs) (y :: ys) (z :: zs) = f x y z :: map3 f xs ys zs
       
    61   | map3 _ _ _ _ = raise Library.UnequalLengths;
       
    62 
       
    63 fun map4 _ [] [] [] [] = []
    45 fun map4 _ [] [] [] [] = []
    64   | map4 f (x :: xs) (y :: ys) (z :: zs) (u :: us) = f x y z u :: map4 f xs ys zs us
    46   | map4 f (x :: xs) (y :: ys) (z :: zs) (u :: us) = f x y z u :: map4 f xs ys zs us
    65   | map4 _ _ _ _ _ = raise Library.UnequalLengths;
    47   | map4 _ _ _ _ _ = raise Library.UnequalLengths;
    66 
       
    67 fun map6 _ [] [] [] [] [] [] = []
       
    68   | map6 f (x :: xs) (y :: ys) (z :: zs) (u :: us) (v :: vs) (w :: ws) = f x y z u v w :: map6 f xs ys zs us vs ws
       
    69   | map6 _ _ _ _ _ _ _ = raise Library.UnequalLengths;
       
    70 
    48 
    71 fun map7 _ [] [] [] [] [] [] [] = []
    49 fun map7 _ [] [] [] [] [] [] [] = []
    72   | map7 f (x :: xs) (y :: ys) (z :: zs) (u :: us) (v :: vs) (w :: ws) (b :: bs) = f x y z u v w b :: map7 f xs ys zs us vs ws bs
    50   | map7 f (x :: xs) (y :: ys) (z :: zs) (u :: us) (v :: vs) (w :: ws) (b :: bs) = f x y z u v w b :: map7 f xs ys zs us vs ws bs
    73   | map7 _ _ _ _ _ _ _ _ = raise Library.UnequalLengths;
    51   | map7 _ _ _ _ _ _ _ _ = raise Library.UnequalLengths;
    74 
    52