-- -- $Id$

module Autolib.Util.DPL 

( value, values )

where

-- dynamic programming on lists


-- import Data.STRef.Lazy
import Data.STRef.Strict
-- import Control.Monad.ST.Lazy
import Control.Monad.ST.Strict

import Autolib.FiniteMap 

import Data.List (inits, tails)
import Control.Monad (guard)


type Cache s a b = STRef s (FiniteMap [a] b)

empty :: (Ord a) => ST s (Cache s a b)
empty :: forall a s b. Ord a => ST s (Cache s a b)
empty = FiniteMap [a] b -> ST s (STRef s (FiniteMap [a] b))
forall a s. a -> ST s (STRef s a)
newSTRef FiniteMap [a] b
forall {k} {a}. Map k a
emptyFM

splits :: [a] -> [([a],[a])]
splits :: forall a. [a] -> [([a], [a])]
splits [a]
xs = [[a]] -> [[a]] -> [([a], [a])]
forall a b. [a] -> [b] -> [(a, b)]
zip ([a] -> [[a]]
forall a. [a] -> [[a]]
inits [a]
xs) ([a] -> [[a]]
forall a. [a] -> [[a]]
tails [a]
xs)

dpl :: (Ord a) 
   => (a -> b) -> ([(b,b)] -> b) 
   -> Cache s a b -> [a] -> ST s b
dpl :: forall a b s.
Ord a =>
(a -> b) -> ([(b, b)] -> b) -> Cache s a b -> [a] -> ST s b
dpl a -> b
unit [(b, b)] -> b
combine Cache s a b
c [a]
xs = do
    f <- Cache s a b -> ST s (FiniteMap [a] b)
forall s a. STRef s a -> ST s a
readSTRef Cache s a b
c
    case lookupFM f xs of
	 Just b
v -> b -> ST s b
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return b
v
	 Maybe b
Nothing -> do
	     v <- case [a]
xs of
		  [   ] -> [Char] -> ST s b
forall a. HasCallStack => [Char] -> a
error [Char]
"DPL.dpl: empty list"
	          [ a
x ] -> b -> ST s b
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> ST s b) -> b -> ST s b
forall a b. (a -> b) -> a -> b
$ a -> b
unit a
x
		  [a]
_     -> do		  
		      vpqs <- [ST s (b, b)] -> ST s [(b, b)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([ST s (b, b)] -> ST s [(b, b)]) -> [ST s (b, b)] -> ST s [(b, b)]
forall a b. (a -> b) -> a -> b
$ do
			   (p, q) <- [a] -> [([a], [a])]
forall a. [a] -> [([a], [a])]
splits [a]
xs
			   guard $ not $ null p
			   guard $ not $ null q    
			   return $ do 
				  vp <- dpl unit combine c p
				  vq <- dpl unit combine c q
				  return (vp, vq)
		      return $ combine vpqs
	     f <- readSTRef c
	     writeSTRef c (addToFM f xs v)
	     return v

value :: Ord a =>  (a -> b) -> ([(b,b)] -> b) -> [a] -> b
value :: forall a b. Ord a => (a -> b) -> ([(b, b)] -> b) -> [a] -> b
value a -> b
unit [(b, b)] -> b
combine [a]
xs = (forall s. ST s b) -> b
forall a. (forall s. ST s a) -> a
runST ( do
    c <- ST s (Cache s a b)
forall a s b. Ord a => ST s (Cache s a b)
empty
    dpl unit combine c xs      )

values :: Ord a => (a -> b) -> ([(b,b)] -> b) -> [[a]] -> [([a],b)]
values :: forall a b.
Ord a =>
(a -> b) -> ([(b, b)] -> b) -> [[a]] -> [([a], b)]
values a -> b
unit [(b, b)] -> b
combine [[a]]
xss = (forall s. ST s [([a], b)]) -> [([a], b)]
forall a. (forall s. ST s a) -> a
runST ( do
    c <- ST s (Cache s a b)
forall a s b. Ord a => ST s (Cache s a b)
empty
    vs <- mapM (dpl unit combine c) xss      
    return $ zip xss vs         )