"we believe in rough consensus and running code"

[xax]

here's some running code i wrote, which i share to inspire you all:

{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, TypeOperators, KindSignatures #-}

module Generation.Layer
  ( Generator(load, check)
  , (?)(..)
  , base
  , layer
  , split
  , render0
  , render1
  , render2
  , render3
  , render4
  , render5
  -- etc
  -- for writing type signatures only:
  , Base
  , Layer
  , Split
  , Term ()
  , Extend ()
  ) where

import Prelude hiding (lookup, map)

import Control.Arrow
import Control.Applicative

import Data.Maybe (fromMaybe)
import Data.Map hiding (foldr, split)
import Data.Monoid
import qualified Data.Set

{-
things to add to make this more practically useful / useful at all

 * unify the extractX and renderX functions, dear god
   * can typefamilies help with this?? can anything help this.

 * unload functions. either explicit (unload x chunk) or implicit (unload all chunks not needed to keep ... (or the area within X distance of it) fully loaded) but i guess it comes down to the same thing really.

 * it would be a radical rearrangement, but a threaded IO version that you ask for coordinates and get a ticket back (a STM ref that either holds 'unloaded' or 'loaded x' or smth), & meanwhile you can poll a stream (??) to see which parts are currently being loaded or unloaded. right now it's very... blocking, and i could imagine generation of something a dozen layers up causing huge hitches as it forceloads huge chunks of stuff
-}

-- at first glance that fundep might seem too exclusive, except all the instances actually look like `Generator (Thing ... m k v) m k v`, which, is basically about as explicit a dependency as you can get
class Generator g m k v | g -> m k v where
  load :: g -> k -> m g
  check :: g -> k -> Maybe v
  -- unloadSaveFor :: g -> [k] -> Int -> g

base :: Ord k => (k -> m v) -> Base m k v
base rv = Base rv mempty

layer :: (Ord k, Generator a m k u) => ([(k, u)] -> k -> u -> m v) -> Int -> (k -> [k]) -> a -> Layer a u m k v
layer gen spread adj prev = Layer gen adj spread mempty prev

split :: (Ord k, Generator a m j v) => (j -> k -> v -> v) -> (j -> [k]) -> (k -> j) -> a -> Split a j m k v
split distribute split merge prev = Split distribute split merge mempty prev

instance (Ord k, Monad m) => Generator (Base m k v) m k v where
  load g k = case check g k of
    Nothing -> do
      v <- _gen g k
      return $ g {_bstore = insert k v (_bstore g)}
    Just _ -> return g
  check g k = lookup k (_bstore g)

instance (Ord k, Monad m, Generator a m k u) => Generator (Layer a u m k v) m k v where
  load l k = case check l k of
    Nothing -> do
      let adjs = adjacentSpread (_adjacent l) (_spread l) k
      (p', adjvs) <- mapAccumM forceLoad (_lprev l) (k:adjs)
      w <- _layer l (zip adjs $ tail adjvs) k (head adjvs)
      return $ l {_lprev = p', _lstore = insert k w (_lstore l)}
    Just _ -> return l
  check l k = lookup k (_lstore l)

instance (Ord k, Ord j, Monad m, Generator a m j v) => Generator (Split a j m k v) m k v where
  load s k = case check s k of
    Nothing -> do
      (p', m) <- forceLoad (_sprev s) (_merge s k)
      let kvs = redistribute (_split s) (_distribute s) (_merge s k) m
      let s' = foldr (uncurry insert) (_sstore s) kvs
      return $ s {_sprev = p', _sstore = s'}
    Just _ -> return s
  check s k = lookup k (_sstore s)

data Base m k v = Base
  { _gen :: k -> m v
  , _bstore :: Map k v
  }

instance Functor m => Functor (Base m k) where
  fmap f b = b {_gen = fmap f . _gen b, _bstore = map f $ _bstore b}

data Layer a u m k v = Layer
  { _layer :: [(k, u)] -> k -> u -> m v
  , _adjacent :: k -> [k]
  -- how many steps adjacent does this layer require data from?
  , _spread :: Int
  , _lstore :: Map k v
  , _lprev :: a
  }

-- for rekeying a generator, and specifically for rekeying a generator where each 'chunk' is split into smaller chunks
data Split a j (m :: * -> *) k v = Split
  { _distribute :: j -> k -> v -> v
  , _split :: j -> [k]
  -- inverse of _split, kind of: any & all `k`s generated from a call to split should generate the `j` that would generate them
  , _merge :: k -> j
  , _sstore :: Map k v
  , _sprev :: a
  }

forceLoad :: (Generator g m k v, Monad m) => g -> k -> m (g, v)
forceLoad g k = do
  g' <- load g k
  return (g', fromMaybe (error "bad forceLoad") $ check g' k)

-- i think this works
adjacentSpread :: Ord k => (k -> [k]) -> Int -> k -> [k]
adjacentSpread adj spread k =
  iterate (\as -> nub . (as ++) . (adj =<<) $ as) [k] !! spread

redistribute :: (j -> [k]) -> (j -> k -> v -> v) -> j -> v -> [(k, v)]
redistribute split distribute j v = fmap (\k -> (k, distribute j k v)) $ split j

mapAccumM :: Monad m => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumM _ z [] = return (z, [])
mapAccumM f z (x:xs) = do
  (z', y) <- f z x
  (zf, ys) <- mapAccumM f z' xs
  return (zf, y:ys)

nub :: Ord k => [k] -> [k]
nub = Data.Set.toList . Data.Set.fromList

{---
- RENDERING FUNCTION(S)
-}

infixr 5 ?
data a ? b = a :? Maybe b

render0
  :: ( Ord k, Term t k v
     )
  => t -> (v -> r) -> Map k r
render0 t f = map f . extract0 $ t

render1
  :: ( Ord k, Term t k v
     , Ord k', Extend e t k k' v'
     )
  => e -> (v ? v' -> r) -> Map k' r
render1 t f = map f . extract1 $ t

render2
  :: ( Ord k, Term t k v
     , Ord k', Extend e t k k' v'
     , Ord k'', Extend f e k' k'' v''
     )
  => f -> (v ? v' ? v'' -> r) -> Map k'' r
render2 t f = map f . extract2 $ t

render3
  :: ( Ord k, Term t k v
     , Ord k', Extend e t k k' v'
     , Ord k'', Extend f e k' k'' v''
     , Ord k''', Extend g f k'' k''' v'''
     )
  => g -> (v ? v' ? v'' ? v''' -> r) -> Map k''' r
render3 t f = map f . extract3 $ t

render4
  :: ( Ord k, Term t k v
     , Ord k', Extend e t k k' v'
     , Ord k'', Extend f e k' k'' v''
     , Ord k''', Extend g f k'' k''' v'''
     , Ord k'''', Extend h g k''' k'''' v''''
     )
  => h -> (v ? v' ? v'' ? v''' ? v'''' -> r) -> Map k'''' r
render4 t f = map f . extract4 $ t

render5
  :: ( Ord k, Term t k v
     , Ord k', Extend e t k k' v'
     , Ord k'', Extend f e k' k'' v''
     , Ord k''', Extend g f k'' k''' v'''
     , Ord k'''', Extend h g k''' k'''' v''''
     , Ord k''''', Extend i h k'''' k''''' v'''''
     )
  => i -> (v ? v' ? v'' ? v''' ? v'''' ? v''''' -> r) -> Map k''''' r
render5 t f = map f . extract5 $ t

extract0
  :: (Ord k, Term t k v
     )
  => t -> Map k v
extract0 t = final t

extract1
  :: ( Ord k, Term t k v
     , Ord k', Extend e t k k' v'
     )
  => e -> Map k' (v ? v')
extract1 e = case next e of
  (t, v') -> case final t of
    v -> unify v' $ rekey e v

extract2
  :: ( Ord k, Term t k v
     , Ord k', Extend e t k k' v'
     , Ord k'', Extend f e k' k'' v''
     )
  => f -> Map k'' (v ? v' ? v'')
extract2 f = case next f of
  (e, v'') -> case next e of
    (t, v') -> case final t of
      v ->
        unify
          (unify
            v''
            $ rekey f v')
          $ rekey f . rekey e $ v

extract3
  :: ( Ord k, Term t k v
     , Ord k', Extend e t k k' v'
     , Ord k'', Extend f e k' k'' v''
     , Ord k''', Extend g f k'' k''' v'''
     )
  => g -> Map k''' (v ? v' ? v'' ? v''')
extract3 g = case next g of
  (f, v''') -> case next f of
    (e, v'') -> case next e of
      (t, v') -> case final t of
        v ->
          unify
            (unify
              (unify
                v'''
                $ rekey g v'')
              $ rekey g . rekey f $ v')
            $ rekey g . rekey f . rekey e $ v

extract4
  :: ( Ord k, Term t k v
     , Ord k', Extend e t k k' v'
     , Ord k'', Extend f e k' k'' v''
     , Ord k''', Extend g f k'' k''' v'''
     , Ord k'''', Extend h g k''' k'''' v''''
     )
  => h -> Map k'''' (v ? v' ? v'' ? v''' ? v'''')
extract4 h = case next h of
  (g, v'''') -> case next g of
    (f, v''') -> case next f of
      (e, v'') -> case next e of
        (t, v') -> case final t of
          v ->
            unify
              (unify
                (unify
                  (unify
                    v''''
                    $ rekey h v''')
                  $ rekey h . rekey g $ v'')
                $ rekey h . rekey g . rekey f $ v')
              $ rekey h . rekey g . rekey f . rekey e $ v

extract5
  :: ( Ord k, Term t k v
     , Ord k', Extend e t k k' v'
     , Ord k'', Extend f e k' k'' v''
     , Ord k''', Extend g f k'' k''' v'''
     , Ord k'''', Extend h g k''' k'''' v''''
     , Ord k''''', Extend i h k'''' k''''' v'''''
     )
  => i -> Map k''''' (v ? v' ? v'' ? v''' ? v'''' ? v''''')
extract5 i = case next i of
  (h, v''''') -> case next h of
    (g, v'''') -> case next g of
      (f, v''') -> case next f of
        (e, v'') -> case next e of
          (t, v') -> case final t of
            v ->
              unify
                (unify
                  (unify
                    (unify
                      (unify
                        v'''''
                        $ rekey i v'''')
                      $ rekey i . rekey h $ v''')
                    $ rekey i . rekey h . rekey g $ v'')
                  $ rekey i . rekey h . rekey g . rekey f $ v')
                $ rekey i . rekey h . rekey g . rekey f . rekey e $ v

class Term t k v | t -> k v where
  final :: t -> Map k v

class Extend e t j k v | e -> t j k v where
  next :: e -> (t, Map k v)
  -- note the unbound type variable here. this means we can't use Split's distribute, so there's going to be some imprecision when it comes time to actually render. this means that rendering functions should do some bounds checking when it would be relevant, or else there might be some serious overdraw if like a x27-divided key has all its components rerendered
  rekey :: e -> Map j a -> Map k a

instance Term (Base m k v) k v where
  final = _bstore

instance Extend (Layer a u m k v) a k k v where
  next = _lprev &&& _lstore
  rekey _ = id

spread :: Ord b => (a -> [b]) -> Map a v -> Map b v
spread f m = fromList $ (\(k, v) -> (,) <$> f k <*> pure v ) =<< toList m

instance Ord k => Extend (Split a j m k v) a j k v where
  next = _sprev &&& _sstore
  rekey s = spread (_split s)

{-
from data.map:
"When calling `mergeWithKey combine only1 only2`, a function combining two IntMaps is created, such that
 * if a key is present in both maps, it is passed with both corresponding values to the combine function. Depending on the result, the key is either present in the result with specified value, or is left out;
 * a nonempty subtree present only in the first map is passed to only1 and the output is added to the result;
 * a nonempty subtree present only in the second map is passed to only2 and the output is added to the result."
-}
unify :: Ord k => Map k a -> Map k b -> Map k (b ? a)
unify = mergeWithKey
  (\_ a b -> Just (b :? Just a))
  -- has a loaded 'higher' layer without a loaded 'lower' layer. this could
  -- just be `const empty`, if we want it to quietly fail instead of crash.
  -- but right now i'd like to know if this case ever happens, since it's
  -- real bad. i could probably be including the key, too.
  (error "unify: bad generation")
  (map $ \b -> b :? Nothing)