merging.hs

{-# LANGUAGE UndecidableInstances, FlexibleInstances #-}
module Main where

import IO
import Control.Concurrent
import Control.Exception
import System.IO.Unsafe
import Data.Ord

class JoinLattice a where
  join :: a -> a -> a
  -- may want compare; a lattice is a poset
  -- with comparison defined by idempotency of join

data Improving a = Imp [a]

unImp :: Improving a -> [a]
unImp (Imp x) = x

joinify :: JoinLattice a => Improving a -> Improving a
joinify = Imp . scanl1 join . unImp

joinify2 :: JoinLattice a => Improving a -> a
joinify2 = foldr1 join . unImp

-- dropSubsumed :: JoinLattice a => Improving a -> Improving a

-- The choice of which list to take the head of is made as soon as it
-- is known which list *has* a head (not necessarily what it is).
-- Therefore, for this to work, the input lists need to always be in a
-- state of possible termination (as produced by, e.g., filter).
-- This can be changed by writing (cons $! x mumble)
merge :: Improving a -> Improving a -> Improving a
merge (Imp xlst) (Imp ylst) =
    Imp (
    (case xlst of
       []   -> ylst
       x:xs -> x:unImp(Imp xs `merge` Imp ylst))
    `unamb`
    (case ylst of
       []   -> xlst
       y:ys -> y:unImp(Imp xlst `merge` Imp ys)))

unamb :: a -> a -> a
a `unamb` b = unsafePerformIO (a `amb` b)

a `amb` b = evaluate a `race` evaluate b

a `race` b =
    do v <- newEmptyMVar
       ta <- forkIO (a >>= putMVar v)
       tb <- forkIO (b >>= putMVar v)
       x <- takeMVar v
       return x

instance Functor Improving where
--    fmap :: (JoinLattice a, JoinLattice b) => (a -> b) -> Improving a -> Improving b
    fmap f (Imp a) = Imp (map f a)

instance Monad Improving where
    x >>= f = -- joinify2 (fmap f x)
        flatten (fmap f x)
            where
              -- flatten :: JoinLattice a => Improving (Improving a) -> Improving a
              flatten (Imp iia) = 
                  case iia of
                    [] -> Imp []
                    ia:ias -> ia `merge` (flatten (Imp ias))

    return x = Imp [x]



instance JoinLattice (Improving a) where
    join = merge

-- Yes, this really does require -XUndecidableInstances -XFlexibleInstances
-- apparently because I could cause a type inference loop by
-- defining several such typeclass interpretations.
instance (Real a) => JoinLattice a where
    join = max

fibonacci 0 = 1
fibonacci 1 = 1
fibonacci n = fibonacci (n-1) + fibonacci (n-2)

-- take 100 (unImp (merge (Imp (filter (> 100000) $ map fibonacci [1..])) (Imp [1000..])))

mumble = do x <- Imp (filter (< 10) $ map fibonacci [1..])
            y <- Imp [1, x, x+1]
            return y

zumble = do x <- Imp [1, 100]
            y <- Imp (filter (< 1000) $ map fibonacci [x..])
            return y

grumble = do x <- [3,4,5]
             y <- [x, 2*x]
             return y

frotz = do x <- Imp [3..300]
           y <- Imp [x, 2*x]
           return y

main = do print $ take 1000 (unImp (merge (Imp [1000..]) (Imp (filter (< 1000000) $ map fibonacci [1..]))))