{-# LANGUAGE DeriveGeneric #-}
-- | Hacks that haven't found their home yet.
module Game.LambdaHack.Common.Misc
  ( FontDefinition(..), HintingMode(..), FontSet(..)
  , makePhrase, makeSentence, squashedWWandW
  , appDataDir
  , xM, xD, minusM, minusM1, minusM2, oneM, tenthM
  , show64With2
  , workaroundOnMainThreadMVar
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import           Control.Concurrent
import           Control.DeepSeq
import           Data.Binary
import qualified Data.Char as Char
import           Data.Int (Int64)
import qualified Data.Map as M
import           GHC.Generics (Generic)
import qualified NLP.Miniutter.English as MU
import           System.Directory (getAppUserDataDirectory)
import           System.Environment (getProgName)
import           System.IO.Unsafe (unsafePerformIO)

data FontDefinition =
    FontProportional Text Int HintingMode  -- ^ filename, size, hinting mode
  | FontMonospace Text Int HintingMode
  | FontMapScalable Text Int HintingMode Int  -- ^ extra cell extension
  | FontMapBitmap Text Int  -- ^ size ignored for bitmap fonts and no hinting
  deriving (Show, Eq, Read, Generic)

instance NFData FontDefinition

instance Binary FontDefinition

data HintingMode =
    HintingHeavy  -- ^ current libfreetype6 default, thin, large letter spacing
  | HintingLight  -- ^ mimics OTF, blurry, thick, tight tracking, accurate shape
  deriving (Show, Eq, Read, Generic)

instance NFData HintingMode

instance Binary HintingMode

data FontSet = FontSet
  { fontMapScalable :: Text
  , fontMapBitmap   :: Text
  , fontPropRegular :: Text
  , fontPropBold    :: Text
  , fontMono        :: Text }
  deriving (Show, Eq, Read, Generic)

instance NFData FontSet

instance Binary FontSet

-- | Re-exported English phrase creation functions, applied to our custom
-- irregular word sets.
makePhrase, makeSentence :: [MU.Part] -> Text
makePhrase = MU.makePhrase irregular
makeSentence = MU.makeSentence irregular

irregular :: MU.Irregular
irregular = MU.Irregular
  { irrPlural =
      M.fromList
        [ ("merchandise", "merchandise")
        , ("Merchandise", "Merchandise")
        , ("stomach", "stomachs") ]
            -- this is both countable and uncountable, but I use it here
            -- only as uncountable, do I overwrite the default
      `M.union` MU.irrPlural MU.defIrregular
  , irrIndefinite = MU.irrIndefinite MU.defIrregular
  }

-- | Apply the @WWandW@ constructor, first representing repetitions
-- as @CardinalWs@.
-- The parts are not sorted, only grouped, to keep the order.
-- The internal structure of speech parts is compared, not their string
-- rendering, so some coincidental clashes are avoided (and code is simpler).
squashedWWandW :: [MU.Part] -> (MU.Part, MU.Person)
squashedWWandW parts =
  let repetitions = group parts
      f [] = error $ "empty group" `showFailure` parts
      f [part] = (part, MU.Sg3rd)  -- avoid prefixing hero names with "a"
      f l@(part : _) = (MU.CardinalWs (length l) part, MU.PlEtc)
      cars = map f repetitions
      person = case cars of
        [] -> error $ "empty cars" `showFailure` parts
        [(_, person1)] -> person1
        _ -> MU.PlEtc
  in (MU.WWandW $ map fst cars, person)

-- | Personal data directory for the game. Depends on the OS and the game,
-- e.g., for LambdaHack under Linux it's @~\/.LambdaHack\/@.
appDataDir :: IO FilePath
appDataDir = do
  progName <- getProgName
  let name = takeWhile Char.isAlphaNum progName
  getAppUserDataDirectory name

-- | Multiplies by a million.
xM :: Int -> Int64
xM k = into @Int64 k * 1000000

-- | Multiplies by a million, double precision.
xD :: Double -> Double
xD k = k * 1000000

minusM, minusM1, minusM2, oneM, tenthM :: Int64
minusM = xM (-1)
minusM1 = xM (-1) - 1
minusM2 = xM (-1) - 2
oneM = xM 1
tenthM = 100000

show64With2 :: Int64 -> Text
show64With2 n =
  let k = 100 * n `divUp` oneM
      l = k `div` 100
      x = k - l * 100
      y = x `div` 10
  in tshow l
     <> if | x == 0 -> ""
           | x == y * 10 -> "." <> tshow y
           | x < 10 -> ".0" <> tshow x
           | otherwise -> "." <> tshow x

-- Global variable for passing the action to run on main thread, if any.
workaroundOnMainThreadMVar :: MVar (IO ())
{-# NOINLINE workaroundOnMainThreadMVar #-}
workaroundOnMainThreadMVar = unsafePerformIO newEmptyMVar