Ticket #66: Frip.hs

{-# OPTIONS_GHC -fglasgow-exts -farrows #-}

import Control.Arrow
import Data.Word (Word32)
import Prelude hiding (id, const)

import System.Time
import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread)
import Control.Concurrent.STM
import Control.Exception (throwDynTo, catchDyn)
import Control.Monad (unless, when)
import Control.Monad.Fix (fix)
import Data.Typeable
import Data.Maybe (isJust)


type Time   = Integer   -- microseconds, leaves 64 bits after ~500,000 years
type DTime  = Word32    -- microseconds, wraps around after about one hour

sleepmax = maxBound `div` 2 :: DTime

secs :: (Integral a, Fractional b) => a -> b    -- assuming argument in microseconds
secs usecs = fromIntegral usecs / 1000000

type Event a = Maybe a


newtype SF a b = SF (DTime -> a -> Bool -> DTime -> (SF a b, b, Bool, DTime))

instance Arrow SF where
  arr f = SF sf
    where
    sf _ x i s = (SF sf, f x, i, s)

  SF f >>> SF g = SF h
    where
    h dt x i s = (f' >>> g', z, k, r)
      where
      (f', y, j, t)  = f dt x i s
      (g', z, k, r)  = g dt y j t

  first (SF f) = SF g
    where
    g dt (x,z) i s = (first f', (y,z), j&&i, if t==0 then 0 else min t s)
      where
      (f', y, j, t) = f dt x i s

  second (SF f) = SF g
    where
    g dt (z,x) i s = (second f', (z,y), j&&i, if t==0 then 0 else min t s)
      where
      (f', y, j, t) = f dt x i s

  SF f *** SF g = SF h
    where
    h dt (a,b) i s = (f' *** g', (x,y), j && k, min t r)
      where
      (f', x, j, t)  = f dt a i s
      (g', y, k, r)  = g dt b i s

  SF f &&& SF g = SF h
    where
    h dt x i s = (f' &&& g', (y,z), j && k, min t r)
      where
      (f', y, j, t)  = f dt x i s
      (g', z, k, r)  = g dt x i s

id :: Arrow a => a b b
id = arr (\x -> x)

const :: b -> SF a b
const x = SF $ \_ _ _ _ -> (const x, x, True, sleepmax)


instance ArrowLoop SF where
  loop (SF f) = SF g
    where
    g dt x i s = (loop f', y, j, t)
      where
      (f', (y,z), j, t) = f dt (x,z) False 0  -- must avoid non-termination
                                              -- of (i&&j) (min s t)

loopre :: c -> SF (a,c) (b,c) -> SF a b
loopre z0 sf = loop' (second (ipre z0) >>> sf)
  where
  loop' (SF f) = SF g
    where
    g dt x i s = (loop' f', y, j, t)
      where
      (f', (y,z), j, t) = f dt (x,z) (i&&j) (min s t)  -- can afford it here,
                                                       -- because of the pre


time :: SF a Time
time = dtime >>> loopre 0 (arr (\(dt,t) -> let t'=t+fromIntegral dt in (t',t'))) --integ 0
  where
  integ s = SF $ \dt _ _ _ -> (integ (s+fromIntegral dt), s, False, 0)

dtime = SF $ \dt _ _ _ -> (dtime, dt, False, 0)

integral :: Fractional a => SF a a
integral = integ 0
  where
  integ s = SF $ \dt x _ _ -> (integ (s+secs dt*x), s, False, 0)


(-->) :: b -> SF a b -> SF a b
y0 --> SF f = SF g
  where
  g dt x i s = (f', y0, False, 0)
    where
    (f', _, _, _) = f dt x i s

(>--) :: a -> SF a b -> SF a b
x0 >-- SF f = SF (\dt _ _ _ -> f dt x0 False 0)

(>=-) :: (a -> a) -> SF a b -> SF a b
g >=- SF f = SF (\dt x _ _ -> f dt (g x) False 0)

pre :: SF a a
pre = ipre (error "Frip: pre: uninitialized")

ipre :: a -> SF a a
ipre x0 = SF (f x0 False 0)
  where
  f x i s  dt y j t  = (SF (f y j t), x, i, s)


switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b
switch (SF f) k = SF g
  where
  g dt x i s = case e of  Nothing  -> (switch g' k, y, j, t)
                          Just z   -> let SF kz = k z in kz dt x i s
    where
    (g', (y,e), j, t) = f dt x i s

rswitch :: SF a b -> SF (a, Event (SF a b)) b
rswitch f = switch (first f) (\g -> (\(x,e) -> (x,Nothing)) >=- rswitch g)

accumby :: (b -> a -> b) -> b -> SF (Event a) (Event b)
accumby f y0 = switch (never &&& id) $ \x -> aux (f y0 x)
  where
  aux y = switch (now y &&& notnow) $ \x -> aux (f y x)

now :: b -> SF a (Event b)
now y = Just y --> never

notnow :: SF (Event a) (Event a)
notnow = Nothing --> id

never :: SF a (Event b)
never = const Nothing

hold :: a -> SF (Event a) a
hold y0 = switch (const y0 &&& id) (\y -> Nothing >-- hold y)


reactimate :: (DTime -> IO (Maybe a)) -> SF a b -> (b -> IO Bool) -> IO ()
reactimate input (SF f0) output
  = do  x0 <- fix (\f -> input sleepmax >>= maybe f return)
        t0 <- getClockTime
        let r = f0 0 x0 False sleepmax
        loop x0 t0 r
  where
  loop x t (SF f, y, _, s)
    = do  keep_running <- output y
          when keep_running $
            do  putStrLn "-00-"
                putStrLn ("stable: " ++ show s)
                m <- input s
                putStrLn "-01-"
                let  (x', idle) = maybe (x,True) (\y->(y,False)) m
                t' <- getClockTime
                let r = f (timediff t' t) x' idle sleepmax
                x' `seq` idle `seq` putStrLn "-02-"
                loop x' t' r

timediff :: ClockTime -> ClockTime -> DTime
timediff (TOD sec1 psec1) (TOD sec2 psec2)
  = fromIntegral $ (sec1-sec2)*1000000 + ((psec1-psec2) `div` 1000000)

data Wakeup = Wakeup deriving Typeable



sf :: SF (Event String) String
sf = proc ev -> do  cnt <- counter -< ev
                    rswitch off -< (cnt, effswitch ev)
  where
  effswitch ev = case ev of  Just "sin"  -> Just sine
                             Just "tim"  -> Just timedisp
                             Just "dt"   -> Just dtdisp
                             Just "cnt"  -> Just id
                             Just "off"  -> Just off
                             _           -> Nothing

timedisp = time >>> arr (\t -> show (fromIntegral (t`div`10000) / 100) ++ "s")
dtdisp = dtime >>> arr (\dt -> show dt ++ "us")

off = const "<off>"

sine = time >>> arr f
  where
  f x = replicate (round (20 + 20 * sin (fromIntegral x / 1000000 * pi)))  '~'

counter = accumby (\n _ -> n+1) 0 >>> hold 0 >>> arr show


main = do  inp <- atomically (newTMVar Nothing)
           forkIO $ fix $ \f -> do  x <- getLine
                                    atomically (putTMVar inp (Just x))
                                    f
           reactimate (input inp) sf (\x -> putStrLn x >> return True)

input inp timo
  | False = undefined  -- timo==0    = atomically trygetev
  | otherwise  = do  alm <- atomically (newTVar False)
                     putStrLn ("timo: " ++ show timo)
                     forkIO $ do  threadDelay (fromIntegral timo)
                                  atomically (writeTVar alm True)
                     atomically (getevent `orElse` waitfor alm)
  where
  getevent  = do  x <- takeTMVar inp
                  when (isJust x) (putTMVar inp Nothing)
                  return (Just x)
  trygetev  = do  mx <- tryTakeTMVar inp
                  maybe  (return Nothing)
                         (\x -> do  when (isJust x) (putTMVar inp Nothing)
                                    return (Just x))
                         mx
  waitfor alm = do  b <- readTVar alm
                    if b  then  return Nothing
                          else  retry