Story.hs

{-# LANGUAGE OverloadedStrings #-}
module Waldo.Story (
    selectStory
  , knapsackSizer
  , Story(..)
  , StoryGuard, StoryOption
  , isIn, browserIs, osIs, netSpeedIs, orgIs, orgMatch, ispIs
  , refererDomainIs
  , pdTestJustIs
  , giveThem, allocate
  ) where

import Data.Maybe
import Data.List
import Control.Monad.Reader
import Data.ByteString.Char8 (ByteString)
import qualified Data.Text as T
import Network.URI
import Text.Regex.TDFA ((=~))

import Waldo.Stalk
import Waldo.Script

type StoryGuard = ReaderT PersonalData Maybe ()
type StoryOption = ReaderT PersonalData Maybe Story

data Story = 
    StoryGoto {
        storyGoto :: T.Text
      }
  | Story {
         storyAltText   :: T.Text
       , storyPanelSets :: [PanelSizes]
       , storyPadX :: Int
       , storyPadY :: Int
       , storyName :: T.Text
       }
  deriving (Show)

selectStory :: ((Int, Int) -> Story -> Maybe Script) -> Script -> [StoryOption] -> PersonalData -> IO Script
selectStory sizer d storyGens pd = do
  --print storyGens
  -- generate stories
  let stories = catMaybes $ map (flip runReaderT pd) storyGens
  --print stories
  -- size the selected scripts
  let scripts = mapMaybe doSize stories
  --print scripts
  -- Get our script, either the default or a selected one.
  return $ fromMaybe d $ listToMaybe scripts
  where
    doSize (s@Story {}) = sizer (pdScreen pd) s
    doSize (StoryGoto t) = Just (ScriptTo t)

knapsackSizer :: Int -> (Int, Int) -> Story -> Maybe Script
knapsackSizer sitePad (w, h) s =
    -- Get the first entry if there is one, the smallest if none of them fit.
    listToMaybe $ (sortCorrectDir sizeLimited) ++ (take 1 areaSortedSized)
  where
    -- selected sort dir by what we know about the screen
    sortCorrectDir =
      if (h > 0) && (w > 0)
      then reverse
      else id
    -- The fitting scripts
    sizeLimited = fitWidth $ fitHeight $ areaSortedSized
    -- sort by area
    areaSortedSized = areaSort allScripts
    -- Of all scripts
    allScripts = do
      combo <- mapM id $ storyPanelSets s
      return $ mkScript (storyName s) (storyAltText s) combo
    areaSort = sortBy (\a b -> compare (scriptArea a) (scriptArea b))
    scriptArea scr = (sHeight scr) * (sWidth scr)
    fitHeight scripts =
      if h > 0
      then filter (\scr -> h > (sHeight scr+storyPadY s+sitePad)) scripts
      else scripts
    fitWidth scripts =
      if w > 0
      then filter (\scr -> w > (sWidth scr+storyPadX s+sitePad)) scripts
      else scripts

refererDomainIs :: String -> StoryGuard
refererDomainIs d =
  asks pdRefURI >>= guard . fromMaybe False . fmap ((isSuffixOf d) . uriRegName) . join . fmap uriAuthority

--refererMatches :: 

pdTestJustIs :: Eq a => (PersonalData -> Maybe a) -> a -> StoryGuard
pdTestJustIs g v = asks g >>= guard . maybe False (v==)

isIn :: ByteString -> StoryGuard
isIn locName = asks pdLocal >>= guard . (not . null . (filter (locName==)))

browserIs :: Browser -> StoryGuard
browserIs b = asks pdBrowser >>= guard . (maybe False (b==))

osIs :: OS -> StoryGuard
osIs os = asks pdOS >>= guard . (maybe False (os==))

netSpeedIs :: NetSpeed -> StoryGuard
netSpeedIs ns = asks pdNetSpeed >>= guard . (maybe False (ns==))

orgIs :: ByteString -> StoryGuard
orgIs o = asks pdOrg >>= guard . (maybe False (o==))

orgMatch :: ByteString -> StoryGuard
orgMatch o = asks pdOrg >>= guard . (maybe False (flip (=~) o))

ispIs :: ByteString -> StoryGuard
ispIs i = asks pdISP >>= guard . (maybe False (i==))

allocate :: MonadPlus m => m () -> a -> m a
allocate cnd r = cnd >> return r

giveThem :: MonadPlus m => m () -> m a -> m a
giveThem = (>>)