Enumerable
code i mentioned back here.( Read more... )
Enumerable
code i mentioned back here.total :: Enumerable a -> Integer
pick :: Monoid a => Enumerable a -> Integer -> Either EnumerableError a
[a]
which is kind of annoying since that’s basically never what you’d actually want)Arbitrary
instance that just did not terminate, since these are nested data structures that can store an arbitrarily complex expression. even after limiting it a bunch i still can get it to churn out nice compact expressions that have a total count of, for example, 4585754857777496571030203272874303312932Applicative
instance is like ~250 characters{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies,
OverlappingInstances,
UndecidableInstances, TypeFamilies,
TypeOperators, ViewPatterns, FlexibleContexts #-}
module Generation.Layer.Render
( Extract(extract)
, render
, (?)(..)
, Term (..)
, Extend (..)
) where
import Prelude hiding (map)
import Data.Map
render :: Extract from (Map k v) => from -> (v -> r) -> Map k r
render t f = map f . extract $ t
infixr 5 ?
data a ? b = a :? Maybe b
class Extract from result where
extract :: from -> result
instance (Term from k v) => Extract from (Map k v) where
extract = final
-- OVERLAPPING
instance (Extend from from' j k v, Extract from' (Map j v'), Show k, Ord k) => Extract from (Map k (v' ? v)) where
extract v = case next v of
(rs, n) -> n `unify` (rekey v) (extract rs)
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)
rekey :: e -> Map j a -> Map k a
unify :: (Ord k, Show k) => Map k a -> Map k b -> Map k (b ? a)
unify = mergeWithKey
(\_ a b -> Just (b :? Just a))
(mapWithKey $ \k b -> error $ "unify: bad generation @ " ++ show k ++ ".")
(map $ \b -> b :? Nothing)
Show
instances aren't really needed except for when i crash on a bad generation, b/c uhhhh it seemed like i wanted at least some vague detail if that situation ever crops up)Extract
type class with a single function, extract
. this type class is let's say creatively instanced so that i can extract any depth of generator (the Term
and Extend
typeclasses) into a set of values. this makes it possible to write a render
function that takes any extractable value (i.e., any generator stack regardless of depth) and a function that renders based on those values, while still typechecking to make sure the types match. (previously: i needed separate functions for each depth of generator){-# LANGUAGE MultiParamTypeClasses, FlexibleInstances,
UndecidableInstances, TypeFamilies #-}
class Appl fun arg t where
appl :: fun -> arg -> t
instance (a ~ a') => Appl (a -> b) a' b where
appl = id
instance {-# OVERLAPPING #-} Appl fun arg (b -> t) => Appl fun (b, arg) t where
appl f (n, rs) = appl f rs n
class Appr fun arg t where
appr :: fun -> arg -> t
instance (a ~ a') => Appr (a -> b) a' b where
appr f = f
instance {-# OVERLAPPING #-} (a ~ a', Appr fun arg t) => Appr (a -> fun) (a', arg) t where
appr f (a, x) = appr (f a) x
render*
functions in this code, which is a more complicated step, but now one i'm a lot more confident that i can figure out.)appl1 :: (a -> t) -> a -> t
appl1 = id
appl2 :: (a -> b -> t) -> (a, b) -> t
appl2 f (a, b) = appl1 (f a) b
appl3 :: (a -> b -> c -> t) -> (a, (b, c)) -> t
appl3 f (a, b) = appl2 (f a) b
appl4 :: (a -> b -> c -> d -> t) -> (a, (b, (c, d))) -> t
appl4 f (a, b) = appl3 (f a) b
appl5 f (a, b) = appl4 (f a) b
appl6 f (a, b) = appl5 (f a) b
-- etc
appr1 :: (a -> t) -> a -> t
appr1 = id
appr2 :: (a -> b -> t) -> (b, a) -> t
appr2 f (n, rs) = appr1 f rs n
appr3 :: (a -> b -> c -> t) -> (c, (b, a)) -> t
appr3 f (n, rs) = appr2 f rs n
appr4 :: (a -> b -> c -> d -> t) -> (d, (c, (b, a))) -> t
appr4 f (n, rs) = appr3 f rs n
appr5 f (n, rs) = appr4 f rs n
appr6 f (n, rs) = appr5 f rs n
-- etc
class Splittable a b c | a -> b c where
_fst :: a -> b
_snd :: a -> c
instance Splittable (a, b) a b where
_fst = fst
_snd = snd
pair :: Splittable a b c => a -> (b, c)
pair a = (_fst a, _snd a)
applg1 :: (a -> t) -> a -> t
applg1 = id
applg2 :: Splittable s a b => (a -> b -> t) -> s -> t
applg2 f (pair -> (a, b)) = applg1 (f a) b
applg3 :: (Splittable s a s', Splittable s' b c) => (a -> b -> c -> t) -> s -> t
applg3 f (pair -> (a, b)) = applg2 (f a) b
applg4 f (pair -> (a, b)) = applg3 (f a) b
applg5 f (pair -> (a, b)) = applg4 (f a) b
applg6 f (pair -> (a, b)) = applg5 (f a) b
apprg1 :: (a -> t) -> a -> t
apprg1 = id
apprg2 :: Splittable s a b => (b -> a -> t) -> s -> t
apprg2 f (pair -> (n, rs)) = apprg1 f rs n
apprg3 :: (Splittable s a s', Splittable s' b c) => (c -> b -> a -> t) -> s -> t
apprg3 f (pair -> (n, rs)) = apprg2 f rs n
apprg4 f (pair -> (n, rs)) = apprg3 f rs n
apprg5 f (pair -> (n, rs)) = apprg4 f rs n
apprg6 f (pair -> (n, rs)) = apprg5 f rs n
render :: (Extend (Extend (Extend ...) v') v) -> (... ? v' ? v -> t) -> Map k t
except i can't even come close to formulating what that type would look like. especially given Extend
isn't a type but instead a typeclass.data BSPControl f a n e = BSPControl
{ minSize :: a
, maxGeneration :: Integer
, splitRange :: (Float, Float)
, divideControl :: Maybe (f a -> f a -> Integer -> Bool)
, includeSmallOverlaps :: Bool
, rebuild :: f a -> f a -> n
, reconnect :: f (TouchState a) -> e
}
delve :: (Graph gr, RandomGen g, Random a, Integral a, Ord a, Num (f a), Applicative f, Metric f, Traversable f) => BSPControl f a n e -> f a -> Rand g (gr n e)
delve c size = liftM (construct c) $ bsp c size
so this is dimension-agnostic binary-space-partitioning code, which is nice, but wow are those a lot of type constraints. for a while i had both Integral a
and Floating a
constraints, which basically meant that there was no possible type that could work with the code. i'd still like to get rid of that Integral
requirement, since it only comes up once in the entire set of functions, and there it's just because i need something i can cast to and from a floating-point value.
(the f
values are expected to be V*
values from Linear
)
the bit that was most confusing at first (how exactly do i determine if n-dimensional axis-aligned prisms are touching) ended up being radically simplified due to Applicative
s:
touching :: (Applicative f, Foldable f, Ord a, Num a) => BSPRoom (f a) -> BSPRoom (f a) -> f (TouchState a)
touching (BSPRoom pos size _) (BSPRoom pos' size' _) =
test <$> pos <*> size <*> pos' <*> size'
where
test :: (Ord a, Num a) => a -> a -> a -> a -> TouchState a
test start1 length1 start2 length2 = if start2 < start1
then test start2 length2 start1 length1
else case min length2 (start1 + length1 - start2) of
x | x < 0 -> NoContact
| x == 0 -> Touching start2
| otherwise -> Overlapping start2 x
since of course if you have axis-aligned prisms you can decompose each of the dimensionality tests, so what this ends up doing is generating a vector that contains contact information for each dimension, and it turns out there are pretty simple rules for figuring out just when a contact vector is "really" touching, which i will LEAVE DETERMINING AS AN EXERCISE FOR THE READER. (hint: all dimensions being Touching
means the two things touch on a single point; all dimensions being Overlapping
means the two things contain a full overlapping subprism.) sadly i haven't really figured out a way to type-agnostically transform that into something useful (e.g., planes or lines) but whatever, the type variables have gotta run out sometime.