incremental-streams.hs

{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE ScopedTypeVariables #-}
module IncrementalStreams where

import Prelude hiding (init)
import Data.Foldable (toList)
import qualified Data.Set as Set
import Data.Set (Set)
import qualified Data.Map as Map
import Data.Map (Map)

class Change a da where
  (<+>) :: a -> da -> a

class Next a where
  next :: a -> a
  nextN :: Int -> a -> a
  nextN n x | n > 0 = nextN (n-1) (next x)
            | n == 0 = x
            | otherwise = error "can't time travel, sorry"
  -- If (stable x == True) then (x == next x) is morally true.
  -- Use this for optimization only.
  stable :: a -> Bool
  stable _ = False

class Next t => Integrable t a | t -> a where
  current :: t -> a
  integrate :: t -> [a] -- return value at each timestep
  integrate x = current x : if stable x then [] else integrate (next x)

-- An initial value followed by a stream of updates.
data Updates a da = Up { init :: !a, deltas :: [da] } deriving (Show)

instance Change a da => Next (Updates a da) where
  stable = null . deltas
  next (Up a (da:das)) = Up (a <+> da) das
  next x@(Up a []) = x

instance Change a da => Integrable (Updates a da) a where current = init


{- ===== SECTION 1: MONOTONE CHANGE ===== -}

type GrowSet a = Updates (Set a) (Set a)
instance Ord a => Change (Set a) (Set a) where (<+>) = Set.union

munion :: Ord a => GrowSet a -> GrowSet a -> GrowSet a
munion x y = Up (init x `Set.union` init y)
                (zipWith Set.union (deltas x) (deltas y))

-- for a growing filter function, see below
mfilter :: (a -> Bool) -> GrowSet a -> GrowSet a
mfilter p (Up x dxs) = Up (Set.filter p x) (map (Set.filter p) dxs)

mintersect :: Ord a => GrowSet a -> GrowSet a -> GrowSet a
mintersect (Up x dxs) (Up y dys) = Up (Set.intersection x y) (loop x y dxs dys)
  where loop x y (dx:dxs) (dy:dys) =
          Set.unions [Set.intersection x dy, Set.intersection dx y, Set.intersection dx dy] :
             loop (Set.union x dx) (Set.union y dy) dxs dys
        loop x y [] [] = []
        loop x y [] dys = loop x y [Set.empty] dys
        loop x y dxs [] = loop x y dxs [Set.empty]


----- RELATIONAL COMPOSITION -----
-- Δ(R ∘ T) = (ΔR ∘ T) ∪ (R' ∘ ΔT)      where R' = R ∪ ΔR
mcompose :: forall a b c. (Ord a, Ord b, Ord c) => GrowSet (a,b) -> GrowSet (b,c) -> GrowSet (a,c)
mcompose (Up r drs) (Up t dts) = Up v dvs
  where
    v:dvs = loop Map.empty Map.empty (r:drs) (t:dts)
    swap :: (a,b) -> (b,a)
    swap (a,b) = (b,a)
    index :: (Ord key, Ord val) => (row -> (key, val)) -> Set row -> Map key (Set val)
    index keyval s = Map.fromListWith Set.union [ (key, Set.singleton val)
                                                | (key,val) <- map keyval (Set.toList s) ]
    join :: Map b (Set a) -> Map b (Set c) -> Set (a,c)
    join ba bc = Set.unions $ toList $ Map.intersectionWith cross ba bc
    cross :: Set a -> Set c -> Set (a,c)
    cross as cs = Set.fromList [(a,c) | a <- toList as, c <- toList cs]
    loop :: Map b (Set a) -> Map b (Set c) -> [Set (a,b)] -> [Set (b,c)] -> [Set (a,c)]
    -- Δ(R ∘ T) = (ΔR ∘ T) ∪ (R' ∘ ΔT)      where R' = R ∪ ΔR
    loop rix tix (dr:drs) (dt:dts) = Set.union (join drix tix) (join rix' dtix)
                                     : loop rix' tix' drs dts
      where (drix, dtix) = (index swap dr, index id dt)
            rix' = Map.unionWith Set.union rix drix
            tix' = Map.unionWith Set.union tix dtix
    loop rix tix [] [] = []
    loop rix tix drs [] = loop rix tix drs [Set.empty]
    loop rix tix [] dts = loop rix tix [Set.empty] dts

-- some examples. try (mcompose foo bar).
foo :: GrowSet (String, Int)
bar :: GrowSet (Int, String)
foo = Up (Set.fromList [("one", 1)]) [Set.empty, Set.fromList [("two", 2)]]
bar = Up (Set.fromList [(2, "too")]) [Set.fromList [(1, "wun")]]


----- FILTER WITH GROWING CONDITION -----
-- Monotonically growing booleans.
-- `Never` is semantically redundant, could just use (fix MaybeLater).
data GrowBool = Now | Never | MaybeLater GrowBool deriving Show
instance Next GrowBool where next Now = Now; next Never = Never; next (MaybeLater p) = p
instance Integrable GrowBool Bool where current Now = True; current _ = False

growFilter :: forall a. Ord a => (a -> GrowBool) -> GrowSet a -> GrowSet a
growFilter p (Up x dxs) = Up y ys
  where y:ys = loop Map.empty (x : dxs)
        loop :: Map a GrowBool -> [Set a] -> [Set a]
        loop todo (dx:dxs) =
          -- Here we take advantage of monotonicity to not care about timing; we treat
          -- time "relatively" rather than "absolutely" when calling (p a).
          let bools = Map.toList $ Map.union todo $ Map.fromList [(a, p a) | a <- Set.toList dx]
              dones = Set.fromList [a | (a, Now) <- bools]
              todo' = Map.fromList [(a, p) | (a, MaybeLater p) <- bools]
          in dones : loop todo' dxs
        loop todo [] | Map.null todo = []
                     | otherwise = loop todo [Set.empty]

-- Example:
exgrow = growFilter (\x -> if even x then MaybeLater Now else Never)
                    (Up Set.empty [Set.singleton i | i <- [2..10]])
-- try "integrate exgrow"