content: {-# LANGUAGE GADTs #-}
  {-# LANGUAGE StandaloneDeriving #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE FlexibleInstances #-}
  
  module TargetList where
  
  import Prelude hiding (length)
  
  import Control.Applicative
  
  
  -- data Target
  
  data Target = TargetCreature Int | TargetPlayer Int
    deriving (Eq, Show, Ord)
  
  isTargetCreature :: Target -> Bool
  isTargetCreature (TargetCreature _) = True
  isTargetCreature (TargetPlayer _)   = False
  
  isTargetPlayer :: Target -> Bool
  isTargetPlayer (TargetCreature _) = False
  isTargetPlayer (TargetPlayer _)   = True
  
  
  -- data TargetList
  
  -- Tyarg t is either () for a list of fixed length with placeholders
  -- or Target for a list of fixed length with actual Target elements
  --
  -- Important properties of a target list are:
  -- * It has a placeholder version and a filled version
  -- * Its length does not depend on its values (it is not a monad)
  -- * If filled, its element targets can be inspected and enumerated
  -- * Single target elements may be replaced by other targets, after which the result type (a) and intermediate predicates can be reevaluated according to the list's new contents
  -- * Predicates in Test nodes may read preceding Target elements; this allows for early filtering when interactively replacing placeholders by actual values (see askTargets below)
  data TargetList t a where
    Nil  :: a -> TargetList t a
    Snoc :: TargetList t (Target -> a) -> t -> TargetList t a
    Test :: (x -> a) -> (x -> Bool) -> TargetList t x -> TargetList t a
  
  instance Functor (TargetList t) where
    fmap f (Nil x)        = Nil (f x)
    fmap f (Snoc xs t)    = Snoc (fmap (f .) xs) t
    fmap f (Test g ok xs) = Test (f . g) ok xs
  
  instance Applicative (TargetList t) where
    pure = Nil
    xs <*> Nil b     = fmap ($ b) xs
    xs <*> Snoc ys t = Snoc ((.) <$> xs <*> ys) t
    xs <*> Test f ok ys = Test fst snd ((\g x -> (g (f x), ok x)) <$> xs <*> ys)
    -- xs <*> Test f ok ys :: TL b
    -- xs :: TL (a -> b)
    -- Test f ok ys :: TL a
    -- f :: x -> a
    -- ok :: x -> Bool
    -- ys :: TL x
    -- gevraagd: Test f' ok' zs :: TL b
    -- misschien: x' ~ (a -> b, x)
    -- f' :: x' -> b
    -- ok' :: x' -> Bool
    -- zs :: TL x'
  
  instance Show a => Show (TargetList Target a) where
    show = show . snd . evaluate
  
  
  -- utility functions that consume TargetLists
  
  evaluate :: TargetList Target a -> ([Target], a)
  evaluate (Nil x)       = ([], x)
  evaluate (Snoc xs t)   = (ts ++ [t], f t) where (ts, f) = evaluate xs
  evaluate (Test f _ xs) = (ts,        f x) where (ts, x) = evaluate xs
  
  length :: TargetList t a -> Int
  length (Nil _)       = 0
  length (Snoc xs _)   = succ (length xs)
  length (Test _ _ xs) = length xs
  
  
  -- TargetList producers
  
  singleTarget :: TargetList () Target
  singleTarget = Snoc (Nil id) ()
  
  targetCreature :: TargetList () Target
  targetCreature = singleTarget <?> isTargetCreature
  
  targetPlayer :: TargetList () Target
  targetPlayer = singleTarget <?> isTargetPlayer
  
  -- http://magiccards.info/pc2/en/39.html
  arcTrailTargets :: TargetList () (Target, Target)
  arcTrailTargets = (,) <$> singleTarget <*> singleTarget <?> uncurry (/=)
  
  infixl 4 <?>
  (<?>) :: TargetList t a -> (a -> Bool) -> TargetList t a
  xs <?> ok = Test id ok xs
  
  
  -- Interactively replace placeholders () by actual targets
  -- The first argument is all available targets in the world
  askTargets :: forall m a. Monad m => ([Target] -> m Target) -> [Target] -> TargetList () a -> m (TargetList Target a)
  askTargets choose = askTargets' (const True)
    where
      askTargets' :: forall a. (a -> Bool) -> [Target] -> TargetList () a -> m (TargetList Target a)
      askTargets' ok ts scheme =
        case scheme of
          Nil x -> return (Nil x)
          Snoc xs () -> do
            xs' <- askTargets choose ts xs
            let (_, f) = evaluate xs'
            let eligibleTargets = filter (ok . f) ts
            chosen <- choose eligibleTargets
            return (Snoc xs' chosen)
          Test f ok' scheme' -> do
            z <- askTargets' (\x -> ok (f x) && ok' x) ts scheme'
            return (f <$> z)
  
  chooseIO :: [Target] -> IO Target
  chooseIO eligibleTargets = do
    putStr ("Possible targets: " ++ show eligibleTargets ++ " !! ")
    index <- read <$> getLine
    return (eligibleTargets !! index)
  
  test0 :: IO (Target, Target)
  test0 = snd . evaluate <$> askTargets chooseIO [TargetCreature 0, TargetCreature 1] arcTrailTargets
  
  test1 :: [(Target, Target)]
  test1 = snd . evaluate <$> askTargets id [TargetCreature 0, TargetCreature 1] arcTrailTargets
  