Как создавать случайные, типизированные функции

Ответ 1

В комментарии DarkOtter упоминаются классы QuickCheck Arbitrary и CoArbitrary, которые, безусловно, являются первым, что вы должны попробовать. QuickCheck имеет этот экземпляр:

instance (CoArbitrary a, Arbitrary b) => Arbitrary (a -> b) where ...

Как бы то ни было, я только вчера читал код QuickCheck, чтобы понять, как это работает, поэтому я могу просто поделиться тем, что узнал, когда он был свежим в моем сознании. QuickCheck построен вокруг типа, который выглядит так (и это не будет точно таким же):

type Size = Int

-- | A generator for random values of type @[email protected]
newtype Gen a = 
    MkGen { -- | Generate a random @[email protected] using the given randomness source and
            -- size. 
            unGen :: StdGen -> Size -> a 
          }

class Arbitrary a where
    arbitrary :: a -> Gen a

Первый трюк заключается в том, что QuickCheck имеет функцию, которая работает так (и я не смог точно определить, как это реализовано):

-- | Use the given 'Int' to \"perturb\" the generator, i.e., to make a new
-- generator that produces different pseudorandom results than the original.
variant :: Int -> Gen a -> Gen a

Затем они используют это для реализации различных экземпляров этого класса CoArbitrary:

class CoArbitrary a where
    -- | Use the given `a` to perturb some generator.
    coarbitrary :: a -> Gen b -> Gen b

-- Example instance: we just treat each 'Bool' value as an 'Int' to perturb with.
instance CoArbitrary Bool where
    coarbitrary False = variant 0
    coarbitrary True = variant 1

Теперь, используя эти штуки, мы хотим:

instance (Coarbitrary a, Arbitrary b) => Arbitrary (a -> b) where
    arbitrary = ...

Я не буду записывать реализацию, но идея такова:

• Используя экземпляр CoArbitrary a и экземпляр Arbitrary b, мы можем сделать функцию \a -> coarbitrary a arbitrary, которая имеет тип a -> Gen b.
• Помните, что Gen b является новым типом для StdGen -> Size -> b, поэтому тип a -> Gen b изоморфен a -> StdGen -> Size -> b.
• Мы можем тривиально написать функцию, которая принимает любую функцию этого последнего типа и переключает порядок аргументов вокруг, чтобы вернуть функцию типа StdGen -> Size -> a -> b.
• Этот перестроенный тип изоморфен Gen (a -> b), поэтому voilà, мы упаковываем перестроенную функцию в Gen, и мы получили наш генератор случайных функций!

Я бы рекомендовал вам прочитать источник QuickCheck, чтобы убедиться в этом сами. Когда вы справитесь с этим, вы только столкнетесь с двумя дополнительными деталями, которые могут замедлить вас. Во-первых, класс Haskell RandomGen имеет этот метод:

-- | The split operation allows one to obtain two distinct random generators.
split :: RandomGen g => g -> (g, g)

Эта операция используется в экземпляре Monad для Gen, и это весьма важно. Один из трюков здесь состоит в том, что StdGen является чистым генератором псевдослучайных чисел; способ Gen (a -> b) заключается в том, что для каждого возможного значения a мы возмущаем генератор b, используем этот возмущенный генератор для генерации результата b, но тогда мы никогда не продвигаем возмущенное состояние генератора; в основном сгенерированная функция a -> b является замыканием над псевдослучайным семенем, и каждый раз, когда мы вызываем ее с некоторым a, мы используем этот конкретный a для детерминированного создания нового семени, а затем использовать его для детерминированного генерации b, который зависит от a и скрытого семени.

Сокращенный тип Seed -> a -> b более или менее суммирует то, что происходит - псевдослучайная функция является правилом для генерации a b из псевдослучайного семени и a. Это не будет работать с генераторами случайных чисел с обязательным стилем.

Во-вторых: вместо прямого использования функции (a -> StdGen -> Size -> b) -> StdGen -> Size -> a -> b, как я описал выше, код QuickCheck имеет promote :: Monad m => m (Gen a) -> Gen (m a), что является обобщением на любой Monad. Когда m является экземпляром функции Monad, promote совпадает с (a -> Gen b) -> Gen (a -> b), поэтому он действительно такой же, как и набросок выше.

Ответ 2

Будет ли что-то в этом направлении соответствовать вашим потребностям?

import Control.Monad.Random

randomFunction :: (RandomGen r, Random a, Num a, Floating a) => Rand r (a -> a)
randomFunction = do
  (a:b:c:d:_) <- getRandoms
  fromList [(\x -> a + b*x, 1), (\x -> a - c*x, 1), (\x -> sin (a*x), 1)]
    -- Add more functions as needed

main = do
  let f = evalRand randomFunction (mkStdGen 1) :: Double -> Double
  putStrLn . show $ f 7.3

EDIT: Основываясь на этой идее, мы можем включать функции, которые имеют разные числа и типы параметров... пока мы частично применяем их, чтобы все они имели одинаковый тип результата.

import Control.Monad.Random

type Value = (Int, Double, String) -- add more as needed

type Function = Value -> String -- or whatever the result type is

f1 :: Int -> Int -> (Int, a, b) -> Int
f1 a b (x, _, _) = a*x + b

f2 :: String -> (a, b, String) -> String
f2 s (_, _, t) = s ++ t

f3 :: Double -> (a, Double, b) -> Double
f3 a (_, x, _) = sin (a*x)

randomFunction :: RandomGen r => Rand r Function
randomFunction = do
  (a:b:c:d:_) <- getRandoms -- some integers
  (w:x:y:z:_) <- getRandoms -- some floats
  n <- getRandomR (0,100)
  cs <- getRandoms -- some characters
  let s = take n cs 
  fromList [(show . f1 a b, 1), (show . f2 s, 1), (show . f3 w, 1)]
    -- Add more functions as needed

main = do
  f <- evalRandIO randomFunction :: IO Function
  g <- evalRandIO randomFunction :: IO Function
  h <- evalRandIO randomFunction :: IO Function
  putStrLn . show $ f (3, 7.3, "hello")
  putStrLn . show $ g (3, 7.3, "hello")
  putStrLn . show $ h (3, 7.3, "hello")

Ответ 3

Спасибо за очень тщательные ответы выше! Ни один из ответов не сделал то, что я искал. Я проследил предложение DarkOtter в комментарии к вопросу и использовал unsafeCoerce, чтобы избежать проверки типа. Основная идея заключается в том, что мы создаем GADT, который объединяет функции Haskell с их типами; система типа, которую я использую, довольно внимательно следит. Марк П. Джонс "Ввод Haskell в Haskell" . Когда бы я хотел получить набор функций Haskell, я сначала принудить их к типам Any, тогда я делаю то, что мне нужно сделать, сшивая их случайным образом. Когда я иду, чтобы оценить новые функции, сначала я верну их обратно к типу, который я хотел. Конечно, это небезопасно; если мой тип проверки ошибочен или я аннотирую функции haskell с неправильными типами, тогда я в итоге получаю ерунду.

Я вставил код, который я тестировал ниже. Обратите внимание, что импортируются два локальных модуля Strappy.Type и Strappy.Utils. Первая - это система типов, упомянутая выше. Второй приносит помощь для стохастических программ.

Примечание: в приведенном ниже коде я использую комбинаторную логику как основной язык. Вот почему мой язык выражения имеет только приложение, а не переменные или абстракцию лямбда.

{-# Language GADTs,  ScopedTypeVariables   #-}

import Prelude hiding (flip)
import qualified  Data.List as List
import Unsafe.Coerce (unsafeCoerce) 
import GHC.Prim
import Control.Monad
import Control.Monad.State
import Control.Monad.Trans
import Control.Monad.Identity
import Control.Monad.Random

import Strappy.Type
import Strappy.Utils (flip)


-- | Helper for turning a Haskell type to Any. 
mkAny :: a -> Any
mkAny x = unsafeCoerce x 


-- | Main data type. Holds primitive functions (Term), their
-- application (App) and annotations.
data Expr a where
    Term :: {eName  :: String, 
             eType  :: Type, 
             eThing :: a} -> Expr a
    App  :: {eLeft  :: (Expr (b -> a)),
             eRight :: (Expr b),
             eType  :: Type}         ->  Expr a 

-- | smart constructor for applications
a <> b = App a b (fst . runIdentity . runTI $ typeOfApp a b)

instance Show (Expr a)   where
    show Term{eName=s} = s
    show App{eLeft=el, eRight=er} = "(" ++ show el ++ " " ++  show er ++ ")"



-- | Return the resulting type of an application. Run type
-- unification.
typeOfApp :: Monad m => Expr a -> Expr b -> TypeInference  m Type
typeOfApp e_left e_right 
    = do t <- newTVar Star 
         case mgu (eType e_left) (eType e_right ->- t) of 
           (Just sub) -> return $ toType (apply sub (eType e_left))
           Nothing -> error $ "typeOfApp: cannot unify " ++
                      show e_left ++ ":: " ++ show (eType e_left) 
                               ++ " with " ++ 
                      show e_right ++ ":: " ++ show (eType e_right ->- t) 

eval :: Expr a -> a
eval Term{eThing=f} = f
eval App{eLeft=el, eRight=er} = (eval el) (eval er)

filterExprsByType :: [Any] -> Type -> TypeInference [] Any
filterExprsByType (e:es) t  
    = do et <- freshInst (eType (unsafeCoerce e :: Expr a))
         let e' = unsafeCoerce e :: Expr a
         case mgu et t of
           Just sub -> do let eOut = unsafeCoerce e'{eType = apply sub et} :: Any
                          return eOut `mplus` rest
           Nothing -> rest
      where rest = filterExprsByType es t
filterExprsByType [] t = lift []


----------------------------------------------------------------------
-- Library of functions

data Library = Library { probOfApp :: Double, -- ^ probability of an expansion
                         libFunctions :: [Any] }

cInt2Expr :: Int -> Expr Int
-- | Convert numbers to expressions. 
cInt2Expr i = Term (show i) tInt i 


--  Some basic library entires. 
t = mkTVar 0                  
t1 = mkTVar 1                  
t2 = mkTVar 2                  
t3 = mkTVar 3                  

cI = Term "I" (t ->- t) id
cS = Term "S" (((t2 ->- t1 ->- t) ->- (t2 ->- t1) ->- t2 ->- t)) $ \f g x -> (f x) (g x)
cB = Term "B" ((t1 ->- t) ->- (t2 ->- t1) ->- t2 ->- t) $ \f g x -> f (g x)
cC = Term "C" ((t2 ->- t1 ->- t2 ->- t) ->- t1 ->- t2 ->- t) $ \f g x -> (f x) g x
cTimes :: Expr (Int -> Int -> Int)
cTimes = Term "*" (tInt ->- tInt ->- tInt) (*)
cPlus :: Expr (Int -> Int -> Int)
cPlus = Term "+" (tInt ->- tInt ->- tInt) (+)
cCons = Term ":"  (t ->- TAp tList t ->- TAp tList t)  (:)
cAppend = Term "++" (TAp tList t ->- TAp tList t ->- TAp tList t) (++)
cHead = Term "head" (TAp tList t ->- t) head
cMap = Term "map" ((t ->- t1) ->- TAp tList t ->- TAp tList t1) map
cEmpty = Term "[]" (TAp tList t) []
cSingle = Term "single" (t ->- TAp tList t) $ \x -> [x]
cRep = Term "rep" (tInt ->- t ->- TAp tList t) $ \n x -> take n (repeat x)
cFoldl = Term "foldl" ((t ->- t1 ->- t) ->- t ->- (TAp tList t1) ->- t) $ List.foldl'
cNums =  [cInt2Expr i | i <- [1..10]]

--  A basic library

exprs :: [Any]
exprs = [mkAny cI, 
         mkAny cS, 
         mkAny cB, 
         mkAny cC, 
         mkAny cTimes, 
         mkAny cCons, 
         mkAny cEmpty,
         mkAny cAppend,
--         mkAny cHead,
         mkAny cMap,
         mkAny cFoldl,
         mkAny cSingle,
         mkAny cRep
        ] 
        ++ map mkAny cNums

library = Library 0.3 exprs


-- | Initializing a TypeInference monad with a Library. We need to
-- grab all type variables in the library and make sure that the type
-- variable counter in the state of the TypeInference monad is greater
-- that that counter.
initializeTI :: Monad m => Library -> TypeInference m ()
initializeTI Library{libFunctions=es} = do put (i + 1)
                                           return ()
    where go n (expr:rest) = let tvs = getTVars (unsafeCoerce expr :: Expr a)
                                 getTVars expr = tv . eType $ expr
                                 m = maximum $ map (readId . tyVarId) tvs 
                             in if null tvs then 0 else go (max n m) rest
          go n [] = n
          i = go 0 es


----------------------------------------------------------------------
----------------------------------------------------------------------
-- Main functions. 
sampleFromExprs :: (MonadPlus m, MonadRandom m) =>
                   Library -> Type -> TypeInference  m (Expr a)
-- | Samples a combinator of type t from a stochastic grammar G. 
sampleFromExprs [email protected]{probOfApp=prApp, libFunctions=exprs} tp 
    = do initializeTI lib
         tp' <- freshInst tp
         sample tp'
    where sample tp = do
            shouldExpand <- flip prApp
            case shouldExpand of
              True -> do t <- newTVar Star
                         (e_left :: Expr (b -> a))  <- unsafeCoerce $ sample (t ->- tp)
                         (e_right :: Expr b) <- unsafeCoerce $ sample (fromType (eType e_left))
                         return $ e_left <> e_right -- return application
              False -> do let cs = map fst . runTI $ filterExprsByType exprs tp
                          guard (not . null $ cs) 
                          i <- getRandomR (0, length cs - 1)
                          return $ unsafeCoerce (cs !! i) 

----------------------------------------------------------------------
----------------------------------------------------------------------

main = replicateM 100 $ 
       do let out =  runTI $ do sampleFromExprs library (TAp tList tInt) 
          x <- catch (liftM (Just . fst)  out)
                     (\_ -> putStrLn "error" >> return Nothing)                       
          case x of 
            Just y  -> putStrLn $ show x ++ " " ++ show (unsafeCoerce (eval y) :: [Int])
            Nothing  -> putStrLn ""