let it leave me like a long breath

this is the full code file for the new-and-improved Enumerable data type, with notes and pleas for help, in preparation for asking #haskell if they can help

module Data.Enumerable
  ( Enumerable (count)
  , select
  , roll
  , draw
  , handOf
  , withdraw
  , enumerate

  , decompose
  , construct

  , mutate
  , breed

  , rangeEnum
  , rangeNum
  , bounds
  , from

  , permutations
  , permutationsA

  , listOf
  , listRangeOf
  , deckOf
  , numPow
  ) where

{- this is a data type which lets you statically index large decks of
 - permutations. an example of use would be

  λ> let foo = V4 <$> rangeNum (1, 1000) <*> rangeNum (1, 1000)
    <*> rangeNum (1, 1000) <*> rangeNum (1, 1000)

, which will get you a `Integral a => Enumerable (V4 a)` value. running

  λ> count foo
  1000000000000

will get you the total size of the deck, at which point you can see the value
at a given index by using `select`:

  λ> select foo 0
  Just (V4 1 1 1 1)

  λ> select foo 2834225256
  Just (V4 257 226 835 3)

  λ> select foo 999999999999
  Just (V4 1000 1000 1000 1000)

these decks also track their internal structure. running `segments` gets you
this:

  λ> segments foo
  [1,1000,1000000,1000000000]

which is a listing of index axes: there is one value which changes by one each
index, one value that changes by one every thousand indices, and so on.

this lets us write `decompose`:

  λ> decompose foo 2834225256
  [256,225,834,2]

which turns an index into a set of axis movements. because of this, it's
possible to 'move around' in the deck, using `mutate`:

  λ> mutate foo 2834225256
  [1834225256,3834225256,2833225256,2835225256,2834224256,2834226256,2834225255
  ,2834225257]

  λ> select foo <$> mutate foo 2834225256
  [Just (V4 257 226 835 2),Just (V4 257 226 835 4),Just (V4 257 226 834 3)
  ,Just (V4 257 226 836 3),Just (V4 257 225 835 3),Just (V4 257 227 835 3)
  ,Just (V4 256 226 835 3),Just (V4 258 226 835 3)]

aka, every element in the deck that has one value one unit different.

this is where things begin to be half-implemented.
* the current Alternative instance ignores segment data
* the current Monad instance is (probably unavoidably) extremely slow

* Monoid and MonadPlus are both implemented in terms of Alternative, so they
  inherit the Alternative issue

so, my specific problems i'm asking for help / insight with, in order of
importance:

* an Alternative instance requires some more complex math that i haven't
  figured out, and would probably involve dropping storing segments as
  [Integer] in favor of some more detailed nested structure (since [Integer]
  only works because <*> multiplies possibility spaces together, a la cartesian
  joins, meaning that every space constructed only with <*> will be a
  n-dimensional rectangular prism. since Alternative could join
  arbitrarily-sized spaces, there's no longer an even "axis length" value to
  store.

* (ultimately i'd like to write a better `listRangeOf` (which takes a deck of
  values and returns the deck of all permutations of lists of that deck between
  the given length, e.g., `listRangeOf (0, 10) $ from [0,1]` would be all lists
  of binary digits from length 0 to 10) that considers values 'adjacent' in
  mutation terms if you can add, remove, or change a single list item. as in,
  in the deck made by `listRangeOf (0,3) $ rangeEnum ('A', 'Z')` [] would be
  adjacent to every single-length list, and something like "AB" would be
  adjacent to "A", "B", and every string like *AB A*B AB*. at a minimum, that
  would require a working Alternative instance, and might require some further
  math, since that adjacency structure is very different from the axis-based
  ones i'm generating now)

* there's a `functionOf :: Enumerable a -> Enumerable b -> Enumerable (a -> b)`
  function. (return the deck of all functions taking all inputs in `a` and
  mapping them to any input in `b`. exhaustively constructs the entire function
  space.) it doesn't work. specifically, it depends on `unselect`, which i'm
  pretty sure cannot be written. however, since i do have `numPow` working, it
  seems possible that there's some other angle to approach this problem that
  doesn't run into the same issue. maybe? `mapWithIndex` is probably writeable,
  and it would just mean having to map a deck into Integers before using
  numPow.

* i'm fairly certain it's impossible to write a performant Monad instance,
  since it would need to evaluate every value in the deck to get the new count,
  but i'd like some confirmation of that

* `withdraw` breaks assumptions about deck structure when it removes values
  from the deck, and i really don't know how to handle that

-}

import Control.Applicative
import Control.Monad
import Data.Monoid
import Data.Maybe (fromMaybe)
import Data.List (mapAccumR)

import Utility.Rand

data Enumerable a = Enumerable
  { count :: Integer
  , segments :: [Integer]
  , selector :: Integer -> a
  }

instance Functor Enumerable where
  fmap f (Enumerable c s g) = Enumerable c s $ f . g

instance Monoid (Enumerable a) where
  mempty = empty
  mappend = (<|>)

-- one after the other
instance Applicative Enumerable where
  pure v = Enumerable 1 [1] $ const v
  (Enumerable c s f) <*> (Enumerable c' s' g) =
    Enumerable (c * c') (s <> ((c *) <$> s')) $ \i -> let
        j = i `mod` c
        k = i `div` c
      in f j $ g k

-- one or the other
{- first problem: i don't know how to merge segments here. since alternatives
   can be joining any-size enumerable decks, with any variety of segments, i'm
   not sure how exactly to store the resulting pair of segments, especially
   since those segments might contain other nested segments.
 -}
instance Alternative Enumerable where
  empty = Enumerable 0 [] $ const (error "no value")
  (Enumerable c s v) <|> (Enumerable c' s' v') =
    Enumerable (c + c') [1] $ \i -> case i - c of
      x | x >= 0 -> v' x
        | otherwise -> v i

{- second problem: this involves actually evaluating every value in the deck,
   which has a performance somewhere between "extremely bad" and
   "computer-destroying". i'm pretty sure it's not possible to make it better?
   since we need to know the total number of combinations, which we can only
   see by checking every value and adding up the individual counts, which means
   evaluating every value in the deck. making a Foldable instance would get rid
   of the `[0..c-1]` part, but not the need to fully evaluate the entire thing
-}
joinEnum :: Enumerable (Enumerable a) -> Enumerable a
joinEnum (Enumerable c s v) = mconcat $ v <$> [0..c-1]

instance Monad Enumerable where
  return = pure
  e >>= f = joinEnum $ f <$> e

instance MonadPlus Enumerable where
  mzero = empty
  mplus = (<|>)

select :: Enumerable a -> Integer -> Maybe a
select enum i
  | i < 0 || i >= count enum = Nothing
  | otherwise = Just $ selector enum i

roll :: RandomGen g => Enumerable a -> Rand g a
roll enum = do
  i <- liftRand $ randomR (0, count enum-1)
  case select enum i of
    Nothing -> error "incoherent enumerable value"
    Just x -> return x

-- ideally this would return Enumerable ([a], Enumerable a), as in return the deck of all hands
handOf :: RandomGen g => Int -> Enumerable a -> Rand g ([a], Enumerable a)
handOf 0 enum = return ([], enum)
handOf s enum = do
  i <- liftRand $ randomR (0, count enum-1)
  let (card, remaining) = draw enum i
  (rest, final) <- handOf (s-1) remaining
  return (card:rest, final)

draw :: Enumerable a -> Integer -> (a, Enumerable a)
draw enum i = case select enum i of
  Nothing -> error $ "incoherent enumerable value"
  Just x -> (x, withdraw enum i)

withdraw :: Enumerable a -> Integer -> Enumerable a
withdraw (Enumerable c s f) i = Enumerable (c-1) s
  $ \i' -> if i' < i then f i' else f (i' + 1)

enumerate :: Enumerable a -> [a]
enumerate enum = fromMaybe (error "incoherent enumerable value") . select enum
  <$> [0..count enum-1]

decompose :: Enumerable a -> Integer -> [Integer]
decompose (Enumerable _ s _) i' = snd $ mapAccumR split i' s
  where
    split :: Integer -> Integer -> (Integer, Integer)
    split i c = (i `mod` c, i `div` c)

maxAxes :: Enumerable a -> [Integer]
maxAxes e = decompose e $ count e - 1

construct :: Enumerable a -> [Integer] -> Integer
construct (Enumerable _ s _) s' = sum $ zipWith (*) s s'

mutate :: Enumerable a -> Integer -> [Integer]
mutate e i = construct e <$> mutateDecomp e (decompose e i)

mutateDecomp :: Enumerable a -> [Integer] -> [[Integer]]
mutateDecomp e i = tail $ recombine $ zip i mutvals
  where
    mutvals = uncurry spread <$> zip (maxAxes e) i
    spread m c = snd <$> filter fst
      [ (c > 0, c - 1)
      , (c < m, c + 1)
      ]
    recombine [] = [[]]
    recombine ((base,vars):rs) = ((:) <$> pure base <*> recombine rs)
      <> ((:) <$> vars <*> pure (fst <$> rs))

breed :: Enumerable a -> Integer -> Integer -> [Integer]
breed e i j = construct e <$> breedDecomp (decompose e i) (decompose e j)

breedDecomp :: [Integer] -> [Integer] -> [[Integer]]
breedDecomp i j = recombine $ zip i j
  where
    recombine [] = [[]]
    recombine ((a,b):rs) = (:) <$> [a,b] <*> recombine rs

-- different ways of specifying a range of values. it's assumed that these
-- atomic elements will have counts less than Int's maxBound and thus can be
-- constructed like this safely.
rangeEnum :: Enum a => (a, a) -> Enumerable a
rangeEnum (lo, hi) = Enumerable c [1] $ \i -> toEnum $ fromEnum lo + fromIntegral i
  where
    all = fromEnum hi - fromEnum lo + 1
    c = fromIntegral all

rangeNum :: Integral a => (a, a) -> Enumerable a
rangeNum (lo, hi) = Enumerable c [1] $ \i -> lo + fromIntegral i
  where
    all = hi - lo + 1
    c = fromIntegral all

bounds :: (Enum a, Bounded a) => Enumerable a
bounds = rangeEnum (minBound, maxBound)

-- this does require evaluating the entire input list, so don't make it too huge
from :: [a] -> Enumerable a
from vs = Enumerable c [1] $ \i -> vs !! fromIntegral i
  where
    c = fromIntegral $ length vs

permutationsA :: [Enumerable (a -> a)] -> Enumerable a -> Enumerable a
permutationsA opts v = foldr addOrNotA v opts

addOrNotA :: Enumerable (a -> a) -> Enumerable a -> Enumerable a
addOrNotA f a = a <> (f <*> a)

permutations :: [a -> a] -> Enumerable a -> Enumerable a
permutations opts v = foldr addOrNot v opts

addOrNot :: (a -> a) -> Enumerable a -> Enumerable a
addOrNot opt v = v <> (opt <$> v)

listOf :: Int -> Enumerable a -> Enumerable [a]
listOf 0 _ = pure []
listOf 1 v = fmap pure v
listOf n v | n < 0 = error "listOf: cannot make < 0-length list"
  | otherwise = (:) <$> v <*> listOf (n - 1) v

listRangeOf :: (Int, Int) -> Enumerable a -> Enumerable [a]
listRangeOf (lo, hi) v
  | lo == hi = listOf lo v
  | lo > hi = error "listOfRange: low end of range cannot be larger than high end"
  | otherwise = listOf lo v `mappend` listRangeOf (lo+1, hi) v

deckOf :: Integer -> Enumerable a -> Enumerable (Enumerable a)
deckOf 0 _ = pure mempty
deckOf 1 v = fmap pure v
deckOf n v
  | n < 0 = error "deckOf: can't make < 0-length deck"
  | otherwise = (\c rs -> pure c <|> rs) <$> v <*> deckOf (n - 1) v

numPow :: Integer -> Enumerable a -> Enumerable (Integer -> a)
numPow ins outs =
  (\o i -> fromMaybe (error "numPow: outside input range") $ select o i)
    <$> outputDecks
  where
    outputDecks = deckOf ins outs

-- i don't know of any way to realistically write this function
unselect :: Enumerable a -> a -> Integer
unselect _ _ = undefined
{-
-- this seems more plausible to be able to write but idk if it would be more helpful
mapWithIndex :: (Integer -> a -> b) -> Enumerable a -> Enumerable b
mapWithIndex f as = undefined
-}

{-
assuming we have `unselect :: Enumerable a -> a -> Integer` (a reverse of `select`)
we can make the function like so:
-}
functionOf :: Enumerable a -> Enumerable b -> Enumerable (a -> b)
functionOf as bs = (. unselect as) <$> numPow (count as) bs