Operational.hs

{-# LANGUAGE GADTs #-}

module Operational where

import Control.Monad

data Program instr a where
  Then   :: instr a -> (a -> Program instr b) -> Program instr b
  Return :: a -> Program instr a

instance Functor (Program instr) where
  fmap f mx = do
    x <- mx
    return (f x)

instance Applicative (Program instr) where
  pure  = return
  (<*>) = ap

instance Monad (Program instr) where
  return = Return

  Return x    >>= js = js x
  i `Then` is >>= js = i `Then` (\x -> is x >>= js)

singleton :: instr a -> Program instr a
singleton i = i `Then` Return

Random.hs

{-# LANGUAGE GADTs #-}

module Random where

import           Operational
import qualified System.Random as R

type Probability = Double
type Random a    = Program RandomInstruction a

data RandomInstruction a where
  Uniform :: [a] -> RandomInstruction a

uniform :: [a] -> Random a
uniform = singleton . Uniform

die :: Random Int
die = uniform [1..6]

sum2Dies = do
  a <- die
  b <- die
  return (a + b)

sample :: Random a -> R.StdGen -> (a, R.StdGen)
sample (Return a)             gen = (a, gen)
sample (Uniform xs `Then` is) gen = sample (is $ xs !! k) gen'
  where (k, gen') = R.randomR (0, length xs - 1) gen

distribution :: Random a -> [(a, Probability)]
distribution (Return a) = [(a, 1)]
distribution (Uniform xs `Then` is) =
  [ (a, p/n) | x      <- xs
             , (a, p) <- distribution (is x) ]
  where n = fromIntegral (length xs)

Stack.hs

{-# LANGUAGE GADTs #-}

module Stack where

import Operational

type StackProgram a = Program StackInstruction a

data StackInstruction a where
  Pop  :: StackInstruction Int
  Push :: Int -> StackInstruction ()

example2 = Pop `Then` \a ->
           Pop `Then` \b ->
           Push (a + b) `Then`
           Return

example3 = Pop `Then` \a ->
           Pop `Then` \b ->
           Return (a * b)

type Stack a = [a]

interpret :: StackProgram a -> Stack Int -> a
interpret (Push a `Then` is) stack     = interpret (is ()) (a:stack)
interpret (Pop    `Then` is) (b:stack) = interpret (is b ) stack
interpret (Return c)         stack     = c

pop :: StackProgram Int
pop = singleton Pop

push :: Int -> StackProgram ()
push = singleton . Push