{-# 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 (Int -> FontDefinition -> ShowS
[FontDefinition] -> ShowS
FontDefinition -> String
(Int -> FontDefinition -> ShowS)
-> (FontDefinition -> String)
-> ([FontDefinition] -> ShowS)
-> Show FontDefinition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FontDefinition] -> ShowS
$cshowList :: [FontDefinition] -> ShowS
show :: FontDefinition -> String
$cshow :: FontDefinition -> String
showsPrec :: Int -> FontDefinition -> ShowS
$cshowsPrec :: Int -> FontDefinition -> ShowS
Show, FontDefinition -> FontDefinition -> Bool
(FontDefinition -> FontDefinition -> Bool)
-> (FontDefinition -> FontDefinition -> Bool) -> Eq FontDefinition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FontDefinition -> FontDefinition -> Bool
$c/= :: FontDefinition -> FontDefinition -> Bool
== :: FontDefinition -> FontDefinition -> Bool
$c== :: FontDefinition -> FontDefinition -> Bool
Eq, ReadPrec [FontDefinition]
ReadPrec FontDefinition
Int -> ReadS FontDefinition
ReadS [FontDefinition]
(Int -> ReadS FontDefinition)
-> ReadS [FontDefinition]
-> ReadPrec FontDefinition
-> ReadPrec [FontDefinition]
-> Read FontDefinition
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FontDefinition]
$creadListPrec :: ReadPrec [FontDefinition]
readPrec :: ReadPrec FontDefinition
$creadPrec :: ReadPrec FontDefinition
readList :: ReadS [FontDefinition]
$creadList :: ReadS [FontDefinition]
readsPrec :: Int -> ReadS FontDefinition
$creadsPrec :: Int -> ReadS FontDefinition
Read, (forall x. FontDefinition -> Rep FontDefinition x)
-> (forall x. Rep FontDefinition x -> FontDefinition)
-> Generic FontDefinition
forall x. Rep FontDefinition x -> FontDefinition
forall x. FontDefinition -> Rep FontDefinition x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FontDefinition x -> FontDefinition
$cfrom :: forall x. FontDefinition -> Rep FontDefinition x
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 (Int -> HintingMode -> ShowS
[HintingMode] -> ShowS
HintingMode -> String
(Int -> HintingMode -> ShowS)
-> (HintingMode -> String)
-> ([HintingMode] -> ShowS)
-> Show HintingMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HintingMode] -> ShowS
$cshowList :: [HintingMode] -> ShowS
show :: HintingMode -> String
$cshow :: HintingMode -> String
showsPrec :: Int -> HintingMode -> ShowS
$cshowsPrec :: Int -> HintingMode -> ShowS
Show, HintingMode -> HintingMode -> Bool
(HintingMode -> HintingMode -> Bool)
-> (HintingMode -> HintingMode -> Bool) -> Eq HintingMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HintingMode -> HintingMode -> Bool
$c/= :: HintingMode -> HintingMode -> Bool
== :: HintingMode -> HintingMode -> Bool
$c== :: HintingMode -> HintingMode -> Bool
Eq, ReadPrec [HintingMode]
ReadPrec HintingMode
Int -> ReadS HintingMode
ReadS [HintingMode]
(Int -> ReadS HintingMode)
-> ReadS [HintingMode]
-> ReadPrec HintingMode
-> ReadPrec [HintingMode]
-> Read HintingMode
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [HintingMode]
$creadListPrec :: ReadPrec [HintingMode]
readPrec :: ReadPrec HintingMode
$creadPrec :: ReadPrec HintingMode
readList :: ReadS [HintingMode]
$creadList :: ReadS [HintingMode]
readsPrec :: Int -> ReadS HintingMode
$creadsPrec :: Int -> ReadS HintingMode
Read, (forall x. HintingMode -> Rep HintingMode x)
-> (forall x. Rep HintingMode x -> HintingMode)
-> Generic HintingMode
forall x. Rep HintingMode x -> HintingMode
forall x. HintingMode -> Rep HintingMode x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep HintingMode x -> HintingMode
$cfrom :: forall x. HintingMode -> Rep HintingMode x
Generic)

instance NFData HintingMode

instance Binary HintingMode

data FontSet = FontSet
  { FontSet -> Text
fontMapScalable :: Text
  , FontSet -> Text
fontMapBitmap   :: Text
  , FontSet -> Text
fontPropRegular :: Text
  , FontSet -> Text
fontPropBold    :: Text
  , FontSet -> Text
fontMono        :: Text }
  deriving (Int -> FontSet -> ShowS
[FontSet] -> ShowS
FontSet -> String
(Int -> FontSet -> ShowS)
-> (FontSet -> String) -> ([FontSet] -> ShowS) -> Show FontSet
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FontSet] -> ShowS
$cshowList :: [FontSet] -> ShowS
show :: FontSet -> String
$cshow :: FontSet -> String
showsPrec :: Int -> FontSet -> ShowS
$cshowsPrec :: Int -> FontSet -> ShowS
Show, FontSet -> FontSet -> Bool
(FontSet -> FontSet -> Bool)
-> (FontSet -> FontSet -> Bool) -> Eq FontSet
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FontSet -> FontSet -> Bool
$c/= :: FontSet -> FontSet -> Bool
== :: FontSet -> FontSet -> Bool
$c== :: FontSet -> FontSet -> Bool
Eq, ReadPrec [FontSet]
ReadPrec FontSet
Int -> ReadS FontSet
ReadS [FontSet]
(Int -> ReadS FontSet)
-> ReadS [FontSet]
-> ReadPrec FontSet
-> ReadPrec [FontSet]
-> Read FontSet
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FontSet]
$creadListPrec :: ReadPrec [FontSet]
readPrec :: ReadPrec FontSet
$creadPrec :: ReadPrec FontSet
readList :: ReadS [FontSet]
$creadList :: ReadS [FontSet]
readsPrec :: Int -> ReadS FontSet
$creadsPrec :: Int -> ReadS FontSet
Read, (forall x. FontSet -> Rep FontSet x)
-> (forall x. Rep FontSet x -> FontSet) -> Generic FontSet
forall x. Rep FontSet x -> FontSet
forall x. FontSet -> Rep FontSet x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FontSet x -> FontSet
$cfrom :: forall x. FontSet -> Rep FontSet x
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 :: [Part] -> Text
makePhrase = Irregular -> [Part] -> Text
MU.makePhrase Irregular
irregular
makeSentence :: [Part] -> Text
makeSentence = Irregular -> [Part] -> Text
MU.makeSentence Irregular
irregular

irregular :: MU.Irregular
irregular :: Irregular
irregular = Irregular :: Map Text Text -> Map Text Text -> Irregular
MU.Irregular
  { irrPlural :: Map Text Text
irrPlural =
      [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
        [ (Text
"merchandise", Text
"merchandise")
        , (Text
"Merchandise", Text
"Merchandise")
        , (Text
"stomach", Text
"stomachs") ]
            -- this is both countable and uncountable, but I use it here
            -- only as uncountable, do I overwrite the default
      Map Text Text -> Map Text Text -> Map Text Text
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Irregular -> Map Text Text
MU.irrPlural Irregular
MU.defIrregular
  , irrIndefinite :: Map Text Text
irrIndefinite = Irregular -> Map Text Text
MU.irrIndefinite Irregular
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 :: [Part] -> (Part, Person)
squashedWWandW [Part]
parts =
  let repetitions :: [[Part]]
repetitions = [Part] -> [[Part]]
forall a. Eq a => [a] -> [[a]]
group [Part]
parts
      f :: [Part] -> (Part, Person)
f [] = String -> (Part, Person)
forall a. HasCallStack => String -> a
error (String -> (Part, Person)) -> String -> (Part, Person)
forall a b. (a -> b) -> a -> b
$ String
"empty group" String -> [Part] -> String
forall v. Show v => String -> v -> String
`showFailure` [Part]
parts
      f [Part
part] = (Part
part, Person
MU.Sg3rd)  -- avoid prefixing hero names with "a"
      f l :: [Part]
l@(Part
part : [Part]
_) = (Int -> Part -> Part
MU.CardinalWs ([Part] -> Int
forall a. [a] -> Int
length [Part]
l) Part
part, Person
MU.PlEtc)
      cars :: [(Part, Person)]
cars = ([Part] -> (Part, Person)) -> [[Part]] -> [(Part, Person)]
forall a b. (a -> b) -> [a] -> [b]
map [Part] -> (Part, Person)
f [[Part]]
repetitions
      person :: Person
person = case [(Part, Person)]
cars of
        [] -> String -> Person
forall a. HasCallStack => String -> a
error (String -> Person) -> String -> Person
forall a b. (a -> b) -> a -> b
$ String
"empty cars" String -> [Part] -> String
forall v. Show v => String -> v -> String
`showFailure` [Part]
parts
        [(Part
_, Person
person1)] -> Person
person1
        [(Part, Person)]
_ -> Person
MU.PlEtc
  in ([Part] -> Part
MU.WWandW ([Part] -> Part) -> [Part] -> Part
forall a b. (a -> b) -> a -> b
$ ((Part, Person) -> Part) -> [(Part, Person)] -> [Part]
forall a b. (a -> b) -> [a] -> [b]
map (Part, Person) -> Part
forall a b. (a, b) -> a
fst [(Part, Person)]
cars, Person
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 :: IO String
appDataDir = do
  String
progName <- IO String
getProgName
  let name :: String
name = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
Char.isAlphaNum String
progName
  String -> IO String
getAppUserDataDirectory String
name

-- | Multiplies by a million.
xM :: Int -> Int64
xM :: Int -> Int64
xM Int
k = Int -> Int64
forall target source. From source target => source -> target
into @Int64 Int
k Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
1000000

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

minusM, minusM1, minusM2, oneM, tenthM :: Int64
minusM :: Int64
minusM = Int -> Int64
xM (-Int
1)
minusM1 :: Int64
minusM1 = Int -> Int64
xM (-Int
1) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
1
minusM2 :: Int64
minusM2 = Int -> Int64
xM (-Int
1) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
2
oneM :: Int64
oneM = Int -> Int64
xM Int
1
tenthM :: Int64
tenthM = Int64
100000

show64With2 :: Int64 -> Text
show64With2 :: Int64 -> Text
show64With2 Int64
n =
  let k :: Int64
k = Int64
100 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
n Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`divUp` Int64
oneM
      l :: Int64
l = Int64
k Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
100
      x :: Int64
x = Int64
k Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
l Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
100
      y :: Int64
y = Int64
x Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
10
  in Int64 -> Text
forall a. Show a => a -> Text
tshow Int64
l
     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if | Int64
x Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0 -> Text
""
           | Int64
x Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
y Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
10 -> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int64 -> Text
forall a. Show a => a -> Text
tshow Int64
y
           | Int64
x Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
10 -> Text
".0" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int64 -> Text
forall a. Show a => a -> Text
tshow Int64
x
           | Bool
otherwise -> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int64 -> Text
forall a. Show a => a -> Text
tshow Int64
x

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