Time bounded function with partial result in Haskell - haskell

Question

An initial value (x), function (f), a predicate (p) and a time bound (t) is given. I want to apply 'f' repeatedly on x till it satisfies the 'p'. But on the same time wanna make sure it doesn't exceeds time limit. If time exceeds 't', it should return the partial result i.e., a pair of a number 'n' and value of applying 'f' n-times on 'x', for the largest n for which it actually performed the computation.
If partial result condition is relaxed, this can be easily programmed as -
import System.Timeout
iter :: a -> (a -> a) -> (a -> Bool) -> Int -> IO (Maybe (Int, a))
iter x f p t = do
let fs = x:(map f fs)
timeout t $ return $! head $ filter (\x -> p $ snd x) $ zip [1..] fs
I want it to have signature similar to -
iter :: a -> (a -> a) -> (a -> Bool) -> Int -> IO (Either (Int, a) (Int, a))
With Left for partial result and Right for complete result.
An silly and trivial example use of above function is -
*Main> iter 1 (+2) (> 1000000) 1000000
Just (500001,1000001)
*Main> iter 1 (+2) (> 1000000) 100000
Nothing
I want the second call to return partial computed result. Is there a simple way to do it?
More practical examples can be Newton–Raphson method or gradient descent.

Answer 1

I believe it is simplest to delegate such tasks to libraries with better abstraction capability than that offered by base, e.g. async:
{-# LANGUAGE BangPatterns #-}
import Control.Concurrent.Async
import Control.Concurrent
iter :: a -> (a -> a) -> (a -> Bool) -> Int -> IO (Either (Int, a) (Int, a))
iter z f p maxt = do
o <- newMVar (0, z)
let loop old#(!i,x) = do
modifyMVar_ o (const $ return old)
if p x then return old else loop (i+1, f x)
race (threadDelay maxt >> readMVar o) (loop (0, z))
race takes two IO actions and returns whichever completes first, killing the other. The left action completes only if the maximum time has elapsed, and that thread is able to read the MVar. Since the other thread holds the MVar for a short period of time (while it is writing the result) the worker will never be interrupted while writing the result.
Note also that the only thing that forces the chain of applications f $ f $ f.. is the predicate p - if you pass a lazy function (e.g. const False) then this will not work as you want. In practice there are few cases when you would use such a function (esp. with numeric computing), so it likely won't be of much concern. But in this case loop does no actual work and builds a ridiculously large number amount of applications:
>iter 2 (\x -> x * x) (const False) (10^6)
Left (472190,Interrupted.
My computer will never be able to print this result because it has 6.8×10^142142 digits. However:
>iter 2 (\x -> x * x) (<0) (10^6)
Left (24,Interrupted
This is a small number with only about 5,000,000 digits.

Answer 2

I believe your best bet is to use an IORef to keep track of the current computation state. Even if the computation is interrupted, its side effects won't be undone. Be sure to use just one IORef for both the counter and the current value; otherwise they could go out of sync in case of a timeout.
I'm not at all experienced with asynchronous code in Haskell, so take this with a grain of salt, but it seems to work.
{-# LANGUAGE BangPatterns #-}
module IterTimeout where
import Control.Applicative
import Data.IORef
import System.Timeout
iter :: a -> (a -> a) -> (a -> Bool) -> Int -> IO (Either (Int, a) (Int, a))
iter x f p t = do
ref <- newIORef (0, x)
result <- timeout t (iterStep f p ref)
maybe (Left <$> readIORef ref) (return . Right) result
iterStep :: (a -> a) -> (a -> Bool) -> IORef (Int, a) -> IO (Int, a)
iterStep f p ref = go
where
go = do
old#(!oldCount, oldVal) <- readIORef ref
if p oldVal
then return old
else writeIORef ref (oldCount + 1, f oldVal) >> go