Hobby Public Radio

A series looking into the Haskell (programming language)

data ReportResult =
    FeelingLevel OpinionScore
    | ReasonsLevel OpinionScore [OpinionReason]
    | DetailedLevel OpinionScore [OpinionReason]
    deriving (Show, Read, Eq)
instance Semigroup ReportResult where
    (FeelingLevel s1) <> (FeelingLevel s2) = FeelingLevel (s1 <> s2)
    (FeelingLevel s1) <> (ReasonsLevel s2 _) = FeelingLevel (s1 <> s2)
    (FeelingLevel s1) <> (DetailedLevel s2 _) = FeelingLevel (s1 <> s2)
    (ReasonsLevel s1 _) <> (FeelingLevel s2) = FeelingLevel (s1 <> s2)
    (ReasonsLevel s1 r1) <> (ReasonsLevel s2 r2) = ReasonsLevel (s1 <> s2) (r1 <> r2)
    (ReasonsLevel s1 r1) <> (DetailedLevel s2 r2) = ReasonsLevel (s1 <> s2) (r1 <> r2)
    (DetailedLevel s1 _) <> (FeelingLevel s2) = FeelingLevel (s1 <> s2)
    (DetailedLevel s1 r1) <> (ReasonsLevel s2 r2) = ReasonsLevel (s1 <> s2) (r1 <> r2)
    (DetailedLevel s1 r1) <> (DetailedLevel s2 r2) = DetailedLevel (s1 <> s2) (r1 <> r2)


instance Monoid ReportResult where
    mempty = DetailedLevel mempty mempty
traitPairScore :: TraitType -> TraitType -> (OpinionScore, [OpinionReason])
traitPairScore a b =
    case traitPairOpinion a b of
            Nothing ->
                mempty

            Just (s, r) ->
                (s, [r])
traitScore :: [TraitType] -> [PersonIntel] -> [TraitType] -> [PersonIntel] -> ReportResult
traitScore originatorTraits originatorIntel targetTraits targetIntel =
    if (Traits `elem` originatorIntel) && (Traits `elem` targetIntel)
        then DetailedLevel score reasons
        else FeelingLevel score
    where
        (score, reasons) = mconcat $ traitPairScore <$> originatorTraits <*> targetTraits
relationScore :: [PersonIntel] -> [Relation] -> ReportResult
relationScore intel relations =
    mconcat $ (relReport oIntel score) <$> visibilities
    where
        score = mconcat $ (relationTypeScore . relationType) <$> relations
        visibilities = mkUniq $ relationVisibility <$> relations
        oIntel = mkUniq $ mapMaybe (\case
                                        Opinions x ->
                                            Just x

                                        _ ->
                                            Nothing)
                                   intel
relReport :: [OpinionIntel]
    -> (OpinionScore, [OpinionReason])
    -> RelationVisibility
    -> ReportResult
relReport intel (score, reasons) visibility =
    case matching of
        Nothing ->
            FeelingLevel score

        Just (BaseOpinionIntel _) ->
            FeelingLevel score

        Just (ReasonsForOpinions _) ->
            ReasonsLevel score reasons

        Just (DetailedOpinions _) ->
            DetailedLevel score reasons
    where
        matching = safeHead $ reverse $ sort $ filter (\x -> opinionIntelVisibility x == visibility) intel
opinionReport :: [TraitType]
    -> [PersonIntel]
    -> [TraitType]
    -> [PersonIntel]
    -> [Relation]
    -> OpinionReport
opinionReport originatorTraits originatorIntel targetTraits targetIntel targetRelations =
    reportResultToOpinionResult $ traitsRep <> relationsRep
    where
        traitsRep = traitScore originatorTraits originatorIntel targetTraits targetIntel
        relationsRep = relationScore originatorIntel targetRelations
data OpinionReport =
    BaseOpinionReport OpinionFeeling
    | OpinionReasonReport OpinionFeeling [OpinionReason]
    | DetailedOpinionReport OpinionScore [OpinionReason]
    deriving (Show, Read, Eq)
reportResultToOpinionResult :: ReportResult -> OpinionReport
reportResultToOpinionResult (FeelingLevel score) =
    BaseOpinionReport $ scoreFeeling score

reportResultToOpinionResult (ReasonsLevel score reasons) =
    OpinionReasonReport (scoreFeeling score) reasons

reportResultToOpinionResult (DetailedLevel score reasons) =
    DetailedOpinionReport (clamp (-100) 100 score) reasons
data PersonName =
    RegularName FirstName FamilyName (Maybe Cognomen)
    | SimpleName FirstName (Maybe Cognomen)
    | RegalName FirstName FamilyName RegnalNumber (Maybe Cognomen)
    deriving (Show, Read, Eq)
Relation json
    originatorId PersonId
    targetId PersonId
    type RelationType
    visibility RelationVisibility
    deriving Show Read Eq
HumanIntelligence json
    personId PersonId
    ownerId PersonId
    level PersonIntel
    deriving Show Read Eq
data PersonIntel =
    Stats
    | Demesne
    | FamilyRelations
    | SecretRelations
    | Opinions OpinionIntel
    | Traits
    deriving (Show, Read, Eq)
personReportTraits = if Traits `elem` targetIntel
                        then Just $ traitReport <$> targetTraits
                        else Nothing
boolToString :: Bool -> String
boolToString n =
    if n
        then "True"
        else "False"
boolToString :: Bool -> String
boolToString True =
    "True"

boolToString False =
    "False"
isBig :: Maybe Int -> String
isBig Nothing =
    "Not at all"

isBig (Just 1) =
    "Just perfect"

isBig (Just n) =
    if n < 10
        then "Just slightly"
        else "Definitely is"
> isBig Nothing
"Not at all"
> isBig $ Just 0
"Just perfect"
> isBig $ Just 50
"Definitely is"
data Customer = Customer
    { customerName :: String
    , customerDiscountPct :: Double
    , vipCustomer :: Bool
    }

totalFee :: Double -> Customer -> Double
totalFee bill cust@(Customer { vipCustomer = True }) =
    bill * 0.9 * customerDiscountPct cust

totalFee bill cust =
    bill * customerDiscountPct cust
count :: [a] -> Int
count [] =
    0

count (x:xs) =
    1 + count xs
fibonacci :: Int -> Int
fibonacci 0 =
    0

fibonacci 1 =
    1

fibonacci n =
    fibonacci (n - 1) + fibonacci (n - 2)
fibonacci :: Int -> Int
fibonacci n =
    case n of
        0 ->
            0

        1 ->
            1

        n ->
            fibonacci (n - 1) + fibonacci (n - 2)
class  Eq a where
  (==) :: a -> a -> Bool
  (/=) :: a -> a -> Bool

  x /= y = not (x == y)
data Size = Small | Medium | Large
    deriving (Show, Read)

instance Eq Size where
    Small == Small = True
    Medium == Medium = True
    Large == Large = True
    _ == _ = False
> Small == Small
True
> Large /= Large
False
data Size = Small | Medium | Large
    deriving (Show, Read, Eq)
class Eq a => Ord a where
    compare :: a -> a -> Ordering
    (<) :: a -> a -> Bool
    (>=) :: a -> a -> Bool
    (>) :: a -> a -> Bool
    (<=) :: a -> a -> Bool
    max :: a -> a -> a
    min :: a -> a -> a
instance Ord Size where
    Small <= _ = True
    Medium <= Small = False
    Medium <= _ = True
    Large <= Large = True
    Large <= _ = False
check :: (Ord a, Show a) => a -> a -> String
check a b =
    case compare a b of
        LT ->
            show a ++ " is smaller than " ++ show b
        GT ->
            show a ++ " is greater than " ++ show b
        EQ ->
            show a ++ " and " ++ show b ++ " are equal"
> check Medium Small
"Medium is greater than Small"
> check Small Large
"Small is smaller than Large"
> check 7 3
"7 is greater than 3"
> check [1, 2] [1, 1, 1]
"[1, 2] is greater than [1, 1, 1]"
data BuildingType = SensorStation
    | ResearchComplex
    | Farm
    | ParticleAccelerator
    | NeutronDetector
    | BlackMatterScanner
    | GravityWaveSensor
    deriving (Show, Read, Eq)

derivePersistField "BuildingType"
newtype StarDate = StarDate { unStarDate :: Int }
    deriving (Show, Read, Eq, Num, Ord)

instance PersistField StarDate where
    toPersistValue (StarDate n) =
        PersistInt64 $ fromIntegral n

    fromPersistValue (PersistInt64 n) =
        Right $ StarDate $ fromIntegral n

    fromPersistValue _ =
        Left "Failed to deserialize"


instance PersistFieldSql StarDate where
    sqlType _ = SqlInt64
newtype PlanetName = PlanetName { unPlanetName :: Text }
instance IsString PlanetName where
    fromString = PlanetName . fromString
data Component = Component
    { componentId :: ComponentId
    , componentLevel :: ComponentLevel
    , componentName :: ComponentName
    , componentDescription :: ComponentDescription
    , componentWeight :: Weight
    , componentSlot :: ComponentSlot
    , componentType :: [ ComponentPower ]
    , componentCost :: RawResources ResourceCost
    , componentChassisType :: ChassisType
    }
    deriving (Show, Read, Eq, Ord)
componentRequirements ShipLongRangeSensors = Just HighSensitivitySensors
componentRequirements ShipBridge = Nothing
componentRequirements VehicleWheeledMotiveSystem = Nothing
componentRequirements VehicleHoverMotiveSystem = Just HoverCrafts
...
Chassis json
    name ChassisName
    tonnage Weight
    type ChassisType
    technology Technology Maybe
    armourSlots SlotAmount
    innerSlots SlotAmount
    outerSlots SlotAmount
    sensorSlots SlotAmount
    weaponSlots SlotAmount
    engineSlots SlotAmount
    motiveSlots SlotAmount
    sailSlots SlotAmount
    deriving Show Read Eq
RequiredComponent json
    chassisId ChassisId
    componentType ComponentType
    level ComponentLevel
    amount ComponentAmount
    deriving Show Read Eq
Design json
    name Text
    ownerId FactionId
    chassisId ChassisId
    deriving Show Read Eq
PlannedComponent json
    designId DesignId
    componentId ComponentId
    level ComponentLevel
    amount ComponentAmount
    deriving Show Read Eq
class RandomGen g where
    next :: g -> (Int, g)
    genRange :: g -> (Int, Int)
    split :: g -> (g, g)
class Random a where
    randomR :: RandomGen g => (a, a) -> g -> (a, g)
    random :: RandomGen g => g -> (a, g)
    randomRs :: RandomGen g => (a, a) -> g -> [a]
    randoms :: RandomGen g => g -> [a]
    randomRIO :: (a, a) -> IO a
    randomIO :: IO a
import System.Random
import Data.List

-- | get n unique entries from given list in random order
-- | if n > length of list, all items of the list will be returned
getR :: RandomGen g => g -> Int -> [a] -> [a]
getR g n xs =
    fmap (xs !!) ids
    where
        ids = take (min n $ length xs) $ nub $ randomRs (0, length xs - 1) g

-- | Returns 4 unique numbers between 1 and 10 (inclusive)
test :: IO [Int]
test = do
    g <- getStdGen
    return $ getR g 4 [1..10]
/api/research/available     ApiAvailableResearchR       GET
/api/research/current       ApiCurrentResearchR         GET POST DELETE
/api/research/production    ApiResearchProductionR      GET
handleFactionResearch date faction = do
    production <- totalProduction $ entityKey faction
    current <- selectList [ CurrentResearchFactionId ==. entityKey faction ] []
    let updated = updateProgress production <$> current
    _ <- updateUnfinished updated
    _ <- handleCompleted date updated $ entityKey faction
    _ <- updateAvailableResearch $ entityKey faction
    return ()
totalProduction fId = do
    pnbs <- factionBuildings fId
    let buildings = join $ fmap snd pnbs
    return $ mconcat $ researchOutput . entityVal <$> buildings
researchOutput Building { buildingType = ResearchComplex } =
    TotalResearchScore
    { totalResearchScoreEngineering = ResearchScore 10
    , totalResearchScoreNatural = ResearchScore 10
    , totalResearchScoreSocial = ResearchScore 10
    }

researchOutput Building { buildingType = ParticleAccelerator } =
    TotalResearchScore
    { totalResearchScoreEngineering = ResearchScore 15
    , totalResearchScoreNatural = ResearchScore 15
    , totalResearchScoreSocial = ResearchScore 0
    }

researchOutput _ = mempty
updateProgress :: TotalResearchScore ResearchProduction -> Entity CurrentResearch -> Entity CurrentResearch
updateProgress prod curr =
    case researchCategory <$> research of
        Just (Engineering _) ->
            entityValL . currentResearchProgressL +~ engResearch $ curr

        Just (NaturalScience _) ->
            entityValL . currentResearchProgressL +~ natResearch $ curr

        Just (SocialScience _) ->
            entityValL . currentResearchProgressL +~ socResearch $ curr

        Nothing ->
            curr
    where
        research = Map.lookup (currentResearchType . entityVal $ curr) techMap
        engResearch = unResearchScore $ totalResearchScoreEngineering prod
        natResearch = unResearchScore $ totalResearchScoreNatural prod
        socResearch = unResearchScore $ totalResearchScoreSocial prod
updateUnfinished updated = do
    let unfinished = filter (not . researchReady . entityVal) updated
    mapM (\x -> replace (entityKey x) (entityVal x)) unfinished
handleCompleted date updated fId = do
    let finished = filter (researchReady . entityVal) updated
    let finishedTech = currentResearchType . entityVal <$> finished
    insertMany_ $ currentToCompleted date . entityVal <$> finished
    insertMany_ $ researchCompleted date fId . (currentResearchType . entityVal) <$> finished
    deleteWhere [ CurrentResearchId <-. fmap entityKey finished ]
    deleteWhere [ AvailableResearchType <-. finishedTech
                , AvailableResearchFactionId ==. fId ]
updateAvailableResearch fId = do
    available <- selectList [ AvailableResearchFactionId ==. fId ] []
    completed <- selectList [ CompletedResearchFactionId ==. fId ] []
    g <- liftIO getStdGen
    let maxAvailable = ResearchLimit 3
    -- reusing same g should not have adverse effect here
    let engCand = getR g (unResearchLimit maxAvailable) $ newAvailableResearch isEngineering maxAvailable available completed
    let natCand = getR g (unResearchLimit maxAvailable) $ newAvailableResearch isNaturalScience maxAvailable available completed
    let socCand = getR g (unResearchLimit maxAvailable) $ newAvailableResearch isSocialScience maxAvailable available completed
    rewriteAvailableResearch fId $ engCand <> natCand <> socCand
newAvailableResearch selector limit available completed =
    if ResearchLimit (length specificCategory) >= limit
        then []
        else candidates
    where
        specificCategory = filter (availableResearchFilter selector) available
        candidates = filter (selector . researchCategory) unlockedAndUnresearched
        unlockedAndUnresearched = filter (\x -> researchType x `notElem` knownTech) unlockedResearch
        unlockedResearch = filter (antecedentsAvailable knownTech) $ unTechTree techTree
        knownTech = completedResearchType . entityVal <$> completed


availableResearchFilter f x =
    maybe False (f . researchCategory) res
    where
        res = Map.lookup (availableResearchType $ entityVal x) techMap
rewriteAvailableResearch fId res = do
    let cats = mkUniq $ fmap (topCategory . researchCategory) res
    unless (null cats) $ do
        deleteWhere [ AvailableResearchFactionId ==. fId
                    , AvailableResearchCategory <-. cats ]
        insertMany_ $ researchToAvailable fId <$> res
CurrentResearch
    type Technology
    progress Int
    factionId FactionId

AvailableResearch
    type Technology
    category TopResearchCategory
    factionId FactionId

CompletedResearch
    type Technology
    level Int
    factionId FactionId
    date Int
data Technology =
    HighSensitivitySensors
    | SideChannelSensors
    | HighTensileMaterials
    | SatelliteTechnology
    | BawleyHulls
    | SchoonerHulls
    | CaravelHulls
    ...
    deriving (Show, Read, Eq, Enum, Bounded, Ord)
data TopResearchCategory =
    Eng
    | NatSci
    | SocSci
    deriving (Show, Read, Eq, Ord)
data ResearchCategory =
    Engineering EngineeringSubField
    | NaturalScience NaturalScienceSubField
    | SocialScience SocialScienceSubField
    deriving (Show, Read, Eq)

data EngineeringSubField =
    Industry
    | Materials
    | Propulsion
    | FieldManipulation
    deriving (Show, Read, Eq)
newtype ResearchScore a = ResearchScore { unResearchScore :: Int }
    deriving (Show, Read, Eq, Ord, Num)
data TotalResearchScore a = TotalResearchScore
    { totalResearchScoreEngineering :: ResearchScore EngineeringCost
    , totalResearchScoreNatural :: ResearchScore NaturalScienceCost
    , totalResearchScoreSocial :: ResearchScore SocialScienceCost
    }
    deriving (Show, Read, Eq)
data EngineeringCost = EngineeringCost
    deriving (Show, Read, Eq)

data NaturalScienceCost = NaturalScienceCost
    deriving (Show, Read, Eq)

data SocialScienceCost = SocialScienceCost
    deriving (Show, Read, Eq)

data ResearchCost = ResearchCost
    deriving (Show, Read, Eq)

data ResearchProduction = ResearchProduction
    deriving (Show, Read, Eq)

data ResearchLeft = ResearchLeft
    deriving (Show, Read, Eq)
data Research = Research
    { researchName :: Text
    , researchType :: Technology
    , researchCategory :: ResearchCategory
    , researchAntecedents :: [Technology]
    , researchCost :: TotalResearchScore ResearchCost
    , researchTier :: ResearchTier
    }
    deriving (Show, Read, Eq)
techMap :: Map.Map Technology Research
techMap = Map.fromList $ (\x -> (researchType x, x)) <$> unTechTree techTree
data Maybe a =
     Nothing
     | Just a
addLots = add 1000
addLots 5
findPodcasts :: [Podcast] -> Text -> [Podcast]
search = findPodcasts loadedPodcasts
myPodcasts = search "tuturto"
processTurn :: (BaseBackend backend ~ SqlBackend,
    BackendCompatible SqlBackend backend, PersistUniqueRead backend,
    PersistQueryWrite backend,
    PersistQueryRead backend, PersistStoreWrite backend, MonadIO m) =>
    ReaderT backend m Time
processTurn = do
    newTime <- advanceTime
    _ <- removeExpiredStatuses newTime
    factions <- selectList [] [ Asc FactionId ]
    _ <- mapM (handleFactionEvents newTime) factions
    mapM_ handleFactionFood factions
    mapM_ (handleFactionConstruction newTime) factions
    _ <- mapM (addSpecialEvents newTime) factions
    -- Doing observations should always be done last to ensure players have
    -- recent reports of property they have full control, ie. planets.
    -- Otherwise it's possible that they'll receive reports that are one
    -- turn out of sync.
    mapM_ (handleFactionObservations newTime) factions
    return newTime
fibs :: Integer -> Integer
fibs 0 = 0
fibs 1 = 1
fibs n = fibs (n-1) + fibs (n-2)
allFibs :: [Integer]
allFibs = 0 : 1 : zipWith (+) allFibs (tail allFibs)
addOne :: [Integer] -> [Integer]
addOne [] = []
addOne (x:xs) = x + 1 : addOne xs
sumAll :: Integer -> [Integer] -> Integer
sumAll n [] = n
sumAll n (x:xs) = sumAll (n + x) xs
evenOnly :: [Integer] -> [Integer]
evenOnly [] = []
evenOnly (x:xs) = 
    if even x
        then x : evenOnly xs
        else evenOnly xs
> map (+1) [1..10]
[2, 3, 4, 5, 6, 7, 8, 9, 10, 11]
> map odd [1..10]
[True, False, True, False, True, False, True, False, True, False]
> foldr (+) 0 [1..10]
55
> foldl (+) 0 [1..10]
55
> sum [1..10]
55
> scanr (+) 0 [1..10]
[55,54,52,49,45,40,34,27,19,10,0]
> scanl (+) 0 [1..10]
[0,1,3,6,10,15,21,28,36,45,55]
> filter odd [1..10]
[1, 3, 5, 7, 9]
> filter even [1..]
[2, 4, 6, 8, 10, 12, 14, 16...]
> take 5 $ filter even [1..] 
[2, 4, 6, 8, 10]
class Functor f where
    fmap :: (a -> b) -> f a -> f b
-- | this really raises x to 2nd power and doesn't double it
double x = x * x
> fmap double [1, 2, 3, 4, 5]
[1, 4, 9, 16, 25]
> fmap show [1, 2, 3, 4, 5]
["1", "2", "3", "4", "5"]
> fmap (x -> x * x) $ Just 2
Just 4
> fmap (x -> x * x) Nothing
Nothing
> fmap double $ Right 5
Right 25
> fmap double $ Left "distance calculation failed because of flux-capacitor malfunction"
Left "distance calculation failed because of flux-capacitor malfunction"
> (fmap . fmap) double (Just [1, 2, 3, 4])
Just [1, 4, 9, 16]
> (fmap . fmap) double Nothing :: Maybe Int
Nothing
> (fmap . fmap) double [Just 1, Just 2, Nothing, Just 3]
[Just 1, Just 4, Nothing, Just 9]
> fmap show [1, 2, 3, 4, 5]
["1", "2", "3", "4", "5"]

> show <$> [1, 2, 3, 4, 5]
["1", "2", "3", "4", "5"]
class Functor f => Applicative f where
    pure :: a -> f a
    (<*>) :: f (a -> b) -> f a -> f b
> (+) <$> [1, 2, 3] <*> [4, 5, 6]
[5,6,7,6,7,8,7,8,9]
> (+) <$> Just 2 <*> Just 5
Just 7
> (+) <$> Just 2 <*> Nothing
Nothing
data PlanetaryStatus =
    GoodHarvest
    | PoorHarvest
    | GoodMechanicals
    | PoorMechanicals
    | GoodChemicals
    | PoorChemicals
    | KragiiAttack

derivePersistField "PlanetaryStatus"
PlanetStatus json
    planetId PlanetId
    status PlanetaryStatus
    expiration Int Maybe
    deriving Show Read Eq
-- | Load planets that are kragii attack candidates
kragiiTargetPlanets :: (MonadIO m, BackendCompatible SqlBackend backend
                           , PersistQueryRead backend, PersistUniqueRead backend) =>
                           Int -> Int -> Key Faction -> ReaderT backend m [Entity Planet]
kragiiTargetPlanets pop farms fId = do
    planets <- E.select $
        E.from $ (planet `E.LeftOuterJoin` population `E.LeftOuterJoin` building `E.LeftOuterJoin` status) -> do
            E.on (status E.?. PlanetStatusPlanetId E.==. E.just (planet E.^. PlanetId)
                  E.&&. status E.?. PlanetStatusStatus E.==. E.val (Just KragiiAttack))
            E.on (building E.?. BuildingPlanetId E.==. E.just (planet E.^. PlanetId))
            E.on (population E.?. PlanetPopulationPlanetId E.==. E.just (planet E.^. PlanetId))
            E.where_ (planet E.^. PlanetOwnerId E.==. E.val (Just fId)
                      E.&&. building E.?. BuildingType E.==. E.val (Just Farm)
                      E.&&. E.isNothing (status E.?. PlanetStatusStatus))
            E.orderBy [ E.asc (planet E.^. PlanetId) ]
            return (planet, population, building)
    let grouped = groupBy ((a, _, _) (b, _, _) -> entityKey a == entityKey b) planets
    let counted = catMaybes $ fmap farmAndPopCount grouped
    let filtered = filter ((_, p, f) ->
                                p >= pop
                                || f >= farms) counted
    let mapped = fmap ((ent, _, _) -> ent) filtered
    return mapped
kragiiAttack date faction = do
    planets <- kragiiTargetPlanets 10 5 $ entityKey faction
    if length planets == 0
        then return Nothing
        else do
            n <- liftIO $ randomRIO (0, length planets - 1)
            let planet = maybeGet n planets
            let statusRec = PlanetStatus <$> fmap entityKey planet
                                         <*> Just KragiiAttack
                                         <*> Just Nothing
            _ <- mapM insert statusRec
            starSystem <- mapM (getEntity . planetStarSystemId . entityVal) planet
            let event = join $ kragiiWormsEvent <$> planet <*> join starSystem <*> Just date
            mapM insert event
removeNews event odds = MaybeT $ do
    res <- liftIO $ roll odds
    case res of
        Success -> do
            _ <- lift $ deleteWhere [ PlanetStatusPlanetId ==. kragiiWormsPlanetId event
                                    , PlanetStatusStatus ==. KragiiAttack
                                    ]
            _ <- tell [ WormsRemoved ]
            return $ Just RemoveOriginalEvent
        Failure -> do
            _ <- tell [ WormsStillPresent ]
    return $ Just KeepOriginalEvent
_ <- deleteWhere [ PlanetStatusExpiration <=. Just date]
data Simple = One
data Colour =
    Red
    | Green
    | Blue
data Payment =
    Cash Double
    | IOU Text
paymentExplanation :: Payment -> Text
paymentExplanation payment =
    case payment of
        Cash amount ->
            "Cash payment of " <> (show amount) <> " euros"
        IOU explanation ->
            explanation
data Maybe a =
    Nothing
    | Just a
invoice :: Maybe Payment -> Text
invoice payment =
    case payment of
        Just x ->
            paymentExplanation x
        Nothing ->
            "No payment to handle"
invoice :: Maybe Payment -> Text
invoice (Just payment) =
    paymentExplanation payment

invoice Nothing =
    "No payment to handle"
data Person = Person
    { personName :: Text
    , personAge :: Age
    }
me = Person { personName = "Tuukka", personAge = 37 }
myAge = personAge me
myName = personName me
newtype Age = { getAge :: Int }
data Payment =
    Cash Double
    | IOU Text
    deriving (Show, Read, Eq)
StarSystem
    name Text
    coordX Int
    coordY Int
    deriving Show Read Eq
Star
    name Text
    starSystemId StarSystemId
    spectralType SpectralType
    luminosityClass LuminosityClass
    deriving Show Read Eq
data SpectralType = O | B | A | F | G | K | M | L | T
    deriving (Show, Read, Eq)
derivePersistField "SpectralType"

data LuminosityClass = Iap | Ia | Iab | Ib | II | III | IV | V | VI | VII
    deriving (Show, Read, Eq)
derivePersistField "LuminosityClass"
Planet
    name Text
    position Int
    starSystemId StarSystemId
    ownerId FactionId Maybe
    gravity Double
    SystemPosition starSystemId position
    deriving Show Read Eq
createSolarSystem = do
    systemId <- insert $ StarSystem "Solar system" 0 0
    starId <- insert $ Star "Sol" systemId G V
    planetId <- insert $ Planet "Terra" 3 systemId Nothing 1.0
    return (systemId, starId, planetId)
res <- runDB createSolarSystem
planets <- runDB $ selectList [ PlanetGravity ==. 1.0 ] [ Asc PlanetId ]
planet <- runDB $ get planetId
_ <- runDB $ update planetId [ PlanetName =. "Earth" ]
_ <- runDB $ delete planetId
_ <- runDB $ deleteWhere [ PlanetGravity >. 2 ]
data Handler =
    Simple (Int -> Boolean)
    | Complex (Int -> Int -> Int)
addOptions (key, article) = case article of
                                Special news ->
                                    (key, Special $ availableOptions news)
                                _ ->
                                    (key, article)

availableOptions :: SpecialNews -> SpecialNews
availableOptions x =
    case x of
        KragiiWorms event _ choice ->
            KragiiWorms event (eventOptions event) choice
data KragiiWormsEvent = KragiiWormsEvent
    { kragiiWormsPlanetId   :: Key Planet
    , kragiiWormsPlanetName :: Text
    , kragiiWormsSystemId   :: Key StarSystem
    , kragiiWormsSystemName :: Text
    , kragiiWormsDate       :: Int
    }

data KragiiWormsChoice =
    EvadeWorms
    | AttackWorms
    | TameWorms

data KragiiResults =
    WormsStillPresent
    | WormsRemoved
    | WormsTamed
    | CropsDestroyed (RawResource Biological)
    | FarmersInjured
class SpecialEvent a b c | a -> b, a -> c where
    eventOptions :: a -> [UserOption b]
    resolveEvent :: ( PersistQueryRead backend, PersistQueryWrite backend
                    , MonadIO m, BaseBackend backend ~ SqlBackend ) =>
                    (Key News, a) -> Maybe b -> ReaderT backend m (Maybe EventRemoval, [c])
data UserOption a =
    UserOption { userOptionTitle :: Text
               , userOptionExplanation :: [Text]
               , userOptionChoice :: a
               }
eventOptions _ = [ UserOption { userOptionTitle = "Avoid the worms"
                              , userOptionExplanation = [ "Keep using fields, while avoiding the worms and hope they'll eventually leave."
                                                        , "50 units of biologicals lost"
                                                        , "25% chance of worms leaving"
                                                        ]
                              , userOptionChoice = EvadeWorms
                            }
                   , ...
                   ]
putApiMessageIdR :: Key News -> Handler Value
putApiMessageIdR mId = do
    (_, _, fId) <- apiRequireFaction
    msg <- requireJsonBody
    let article = fromDto msg
    _ <- if isSpecialEvent article
            then do
                loadedMessages <- runDB $ selectList [ NewsId ==. mId
                                                     , NewsFactionId ==. fId ] [ Asc NewsDate ]
                if length loadedMessages == 0
                    then apiNotFound
                    else runDB $ update mId [ NewsContent =. (toStrict $ encodeToLazyText article) ]
            else apiForbidden "unsupported article type"
    loadAllMessages fId
resolveEvent keyEventPair (Just choice) =
    runWriterT . runMaybeT $
        case choice of
                EvadeWorms ->
                    chooseToAvoid keyEventPair

                AttackWorms ->
                    chooseToAttack keyEventPair

                TameWorms ->
                    chooseToTame keyEventPair

resolveEvent keyEventPair Nothing =
    runWriterT . runMaybeT $ noChoice keyEventPair
chooseToAvoid :: ( MonadIO m, PersistQueryWrite backend
                 , BaseBackend backend ~ SqlBackend ) =>
                 (Key News, KragiiWormsEvent)
                 -> MaybeT (WriterT [KragiiResults] (ReaderT backend m)) EventRemoval
chooseToAvoid (_, event) = do
    faction <- getFaction event
    (cost, bioLeft) <- calculateNewBio (RawResource 50) (entityVal faction)
    _ <- destroyCrops faction cost bioLeft
    removeNews $ PercentileChance 25
getFaction :: ( MonadIO m, PersistStoreRead backend
              , BaseBackend backend ~ SqlBackend ) =>
              KragiiWormsEvent
              -> MaybeT (WriterT [KragiiResults] (ReaderT backend m)) (Entity Faction)
getFaction event = MaybeT $ do
    planet <- lift $ get $ kragiiWormsPlanetId event
    let owner = join $ fmap planetOwnerId planet
    res <- lift $ mapM getEntity owner
    return $ join res
calculateNewBio :: Monad m =>
                RawResource Biological -> Faction
                -> MaybeT (WriterT [KragiiResults] m) ((RawResource Biological), (RawResource Biological))
calculateNewBio cost faction = MaybeT $ do
    let currentBio = factionBiologicals faction
    return $ if currentBio > 0
                then Just $ ( cost
                            , RawResource $ max 0 (currentBio - unRawResource cost))
                else Nothing
destroyCrops :: ( MonadIO m, PersistQueryWrite backend, BaseBackend backend ~ SqlBackend ) =>
                Entity Faction -> RawResource Biological
                -> RawResource Biological -> MaybeT (WriterT [KragiiResults] (ReaderT backend m)) ()
destroyCrops faction cost bioLeft = MaybeT $ do
    _ <- lift $ updateWhere [ FactionId ==. entityKey faction ]
                            [ FactionBiologicals =. unRawResource bioLeft ]
    tell [ CropsDestroyed cost ]
    return $ Just ()
removeNews :: ( PersistStoreWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend ) =>
              PercentileChance -> MaybeT (WriterT [KragiiResults] (ReaderT backend m)) EventRemoval
removeNews odds = MaybeT $ do
res <- liftIO $ roll odds
    case res of
        Success -> do
            _ <- tell [ WormsRemoved ]
            return $ Just RemoveOriginalEvent
        Failure -> do
            _ <- tell [ WormsStillPresent ]
            return $ Just KeepOriginalEvent
( [KragiiResults], Maybe EventRemoval )
handleFactionEvents :: (BaseBackend backend ~ SqlBackend
                       , PersistStoreWrite backend, PersistQueryRead backend
                       , PersistQueryWrite backend, MonadIO m) =>
                       Time -> Entity Faction -> ReaderT backend m [Key News]
handleFactionEvents date faction = do
    loadedMessages <- selectList [ NewsFactionId ==. (entityKey faction)
                                 , NewsSpecialEvent ==. UnhandledSpecialEvent ] [ Desc NewsDate ]
    let specials = mapMaybe extractSpecialNews $ parseNewsEntities loadedMessages
    mapM (handleSpecialEvent (entityKey faction) date) specials
handleSpecialEvent :: (PersistQueryWrite backend, MonadIO m
                      , BaseBackend backend ~ SqlBackend) =>
                      Key Faction -> Time -> (Key News, SpecialNews) -> ReaderT backend m (Key News)
handleSpecialEvent fId date (nId, (KragiiWorms event _ choice)) = do
    (removal, results) <- resolveEvent (nId, event) choice
    _ <- when (removal /= Just KeepOriginalEvent) $
                    updateWhere [ NewsId ==. nId ]
                                [ NewsSpecialEvent =. HandledSpecialEvent
                                , NewsDismissed =. True ]
    insert $ report fId date event choice results
class ResultsReport a b c | a -> b, a -> c where
report :: Key Faction -> Time -> a -> Maybe b -> [c] -> News
instance ResultsReport KragiiWormsEvent KragiiWormsChoice KragiiResults where
    report fId date event choice results =
        let
            content = KragiiNews { kragiiNewsPlanetId = kragiiWormsPlanetId event
                                 , kragiiNewsPlanetName = kragiiWormsPlanetName event
                                 , kragiiNewsSystemId = kragiiWormsSystemId event
                                 , kragiiNewsSystemName = kragiiWormsSystemName event
                                 , kragiiNewsExplanation = repText
                                 , kragiiNewsDate = timeCurrentTime date
                                 }
        in
            mkNews fId date $ KragiiResolution content
        where
            repText = header choice <> " " <> removed choice (WormsRemoved `elem` results) <> " " <> injury <> " " <> destruction <> " "

            header (Just EvadeWorms) = "Local farmers had chosen to work on their fields, while avoiding the kragii worms."
            header (Just AttackWorms) = "Local farmers had decided to attack the worms with chemicals and burning."
            header (Just TameWorms) = "Decision to try and tame the kragii had been taken."
            header Nothing = "No decision what to do about worms had been taken."

            removed (Just EvadeWorms) True = "After some time, there has been no new kragii sightings and it seems that the threat is now over."
            removed (Just AttackWorms) True = "Attacks seem to have worked and there has been no new kragii sightings."
            removed (Just TameWorms) True = "Kragii has been tamed and put into use of improving soil quality."
            removed Nothing True = "Despite farmers doing nothing at all about the situation, kragii worms disappeared eventually."
            removed (Just EvadeWorms) False = "Kragii are still present on the planet and hamper farming operations considerability."
            removed (Just AttackWorms) False = "Despite the best efforts of farmers, kragii threat is still present."
            removed (Just TameWorms) False = "Taming of the worms was much harder than anticipated and they remain wild."
            removed Nothing False = "While farmers were debating best course of action, kragii reigned free and destroyed crops."

            injury = if FarmersInjured `elem` results
                        then "Some of the personnel involved in the event were seriously injured."
                        else "There are no known reports of personnel injuries."

            totalDestroyed = mconcat $ map (x -> case x of
                                                    CropsDestroyed n -> n
                                                    _ -> mempty) results
            destruction = if totalDestroyed > RawResource 0
                            then "In the end, " <> pack (show (unRawResource totalDestroyed)) <> " units of harvest was destroyed."
                            else "Despite of all this, no harvest was destroyed."
/api/message           ApiMessageR      GET POST
/api/message/#NewsId   ApiMessageIdR    DELETE
/api/icon              ApiMessageIcons  GET
News json
    content Text
    factionId FactionId
    date Int
    dismissed Bool
deriving Show Read Eq
data NewsArticle =
    StarFound StarFoundNews
    | PlanetFound PlanetFoundNews
    | UserWritten UserWrittenNews
    | DesignCreated DesignCreatedNews
    | ConstructionFinished ConstructionFinishedNews


data PlanetFoundNews = PlanetFoundNews
    { planetFoundNewsPlanetName :: Text
    , planetFoundNewsSystemName :: Text
    , planetFoundNewsSystemId   :: Key StarSystem
    , planetFoundNewsPlanetId   :: Key Planet
    , planetFoundNewsDate       :: Int
    }
parseNews :: News -> Maybe NewsArticle
parseNews =
    decode . toLazyByteString . encodeUtf8Builder . newsContent
parseNews news =
    let
        content = newsContent news
        utf8Encoded = encodeUtf8Builder content
        byteString = toLazyByteString utf8Encoded
    in
        decode byteString
parseNewsEntity :: Entity News -> (Key News, Maybe NewsArticle)

parseNewsEntities :: [Entity News] -> [(Key News, NewsArticle)]
$(deriveJSON defaultOptions ''PlanetFoundNews)
$(deriveJSON defaultOptions ''NewsArticle)
data NewsArticleDto =
    StarFoundDto StarFoundNewsDto
    | PlanetFoundDto PlanetFoundNewsDto
    | UserWrittenDto UserWrittenNewsDto
    | DesignCreatedDto DesignCreatedNewsDto
    | ConstructionFinishedDto ConstructionFinishedNewsDto
    deriving (Show, Read, Eq)

data PlanetFoundNewsDto = PlanetFoundNewsDto
    { planetFoundNewsDtoPlanetName :: Text
    , planetFoundNewsDtoSystemName :: Text
    , planetFoundNewsDtoSystemId   :: Key StarSystem
    , planetFoundNewsDtoPlanetId   :: Key Planet
    , planetFoundNewsDtoDate       :: Int
    }
    deriving (Show, Read, Eq)
class (ToJSON d) => ToDto c d | c -> d where
    toDto :: c -> d
instance ToDto PlanetFoundNews PlanetFoundNewsDto where
    toDto news =
        PlanetFoundNewsDto { planetFoundNewsDtoPlanetName = planetFoundNewsPlanetName news
                           , planetFoundNewsDtoSystemName = planetFoundNewsSystemName news
                           , planetFoundNewsDtoSystemId = planetFoundNewsSystemId news
                           , planetFoundNewsDtoPlanetId = planetFoundNewsPlanetId news
                           , planetFoundNewsDtoDate = planetFoundNewsDate news
                           }

instance ToDto NewsArticle NewsArticleDto where
    toDto news =
        case news of
            (StarFound x) -> StarFoundDto $ toDto x
            (PlanetFound x) -> PlanetFoundDto $ toDto x
            (UserWritten x) -> UserWrittenDto $ toDto x
            (DesignCreated x) -> DesignCreatedDto $ toDto x
            (ConstructionFinished x) -> ConstructionFinishedDto $ toDto x
data NewsDto = NewsDto
    { newsDtoId    :: Key News
    , newsContents :: NewsArticleDto
    , newsIcon     :: Text
    }
    deriving (Show, Read, Eq)
instance ToDto ((Key News, NewsArticle), (IconMapper NewsArticleDto)) NewsDto where
    toDto ((nId, article), icons) =
        let
            content = toDto article
        in
        NewsDto { newsDtoId = nId
                , newsContents = content
                , newsIcon = runIconMapper icons content
                }
newtype IconMapper a =
    IconMapper { runIconMapper :: a -> Text }
iconMapper :: (Route App -> Text) -> IconMapper UserNewsIconDto -> IconMapper NewsArticleDto
iconMapper render userIconMapper =
    IconMapper $ article ->
        case article of
            PlanetFoundDto _->
                render $ StaticR images_news_planet_png

            UserWrittenDto details ->
                runIconMapper userIconMapper $ userWrittenNewsDtoIcon details
    ...
instance ToJSON NewsDto where
    toJSON (NewsDto { newsDtoId = nId
                    , newsContents = contents
                    , newsIcon = icon }) =
        object [ "id" .= nId
               , "contents" .= contents
               , "tag" .= jsonTag contents
               , "icon" .= icon
               , "starDate" .= newsStarDate contents
               ]

instance ToJSON PlanetFoundNewsDto where
    toJSON (PlanetFoundNewsDto { planetFoundNewsDtoPlanetName = pName
                               , planetFoundNewsDtoSystemId = sId
                               , planetFoundNewsDtoPlanetId = pId
                               , planetFoundNewsDtoSystemName = sName
                               }) =
        object [ "planetName" .= pName
               , "systemName" .= sName
               , "planetId" .= pId
               , "systemId" .= sId
               ]
getApiMessageR :: Handler Value
getApiMessageR = do
    (_, _, fId) <- apiRequireFaction
    loadAllMessages fId
loadAllMessages :: Key Faction -> HandlerFor App Value
loadAllMessages fId = do
    loadedMessages <- runDB $ selectList [ NewsFactionId ==. fId
                                         , NewsDismissed ==. False ] [ Desc NewsDate ]
    let parsedMessages = parseNewsEntities loadedMessages
    render <- getUrlRender
    let userIcons = userNewsIconMapper render
    return $ toJSON $ map (toDto . (flip (,) (iconMapper render userIcons))) parsedMessages
newtype RawResource a = RawResource { unRawResource :: Int }
    deriving (Show, Read, Eq)
data Biological = Biological
data Mechanical = Mechanical
data Chemical = Chemical
  harvest :: RawResource Biological
  harvest = RawResource 100
instance Num (RawResource t) where
    (+) (RawResource a) (RawResource b) = RawResource $ a + b
    (-) (RawResource a) (RawResource b) = RawResource $ a - b
    (*) (RawResource a) (RawResource b) = RawResource $ a * b
    abs (RawResource a) = RawResource $ abs a
    signum (RawResource a) = RawResource $ signum a
    fromInteger a = RawResource $ fromInteger a
  stock :: RawResource Biological
  stock = RawResource 1000

  harvest :: RawResource Biological
  harvest = RawResource 100

  newStock = stock + harvest
instance Ord (RawResource t) where
    (<=) (RawResource a) (RawResource b) = a <= b
instance Semigroup (RawResource t) where
    (<>) a b = a + b

instance Monoid (RawResource t) where
    mempty = RawResource 0
  harvests :: [RawResource Biological]
  harvests = [RawResource 20, RawResource 50, RawResource 25]

  total :: RawResource Biological
  total = mappend harvests
data RawResources a = RawResources
    { ccdMechanicalCost :: RawResource Mechanical
    , ccdBiologicalCost :: RawResource Biological
    , ccdChemicalCost :: RawResource Chemical
    } deriving (Show, Read, Eq)

data ResourceCost = ResourceCost
data ConstructionSpeed = ConstructionSpeed
data ConstructionLeft = ConstructionLeft
data ConstructionDone = ConstructionDone
data ResourcesAvailable = ResourcesAvailable
instance Semigroup (RawResources t) where
    (<>) a b = RawResources
        { ccdMechanicalCost = ccdMechanicalCost a <> ccdMechanicalCost b
        , ccdBiologicalCost = ccdBiologicalCost a <> ccdBiologicalCost b
        , ccdChemicalCost = ccdChemicalCost a <> ccdChemicalCost b
        }

instance Monoid (RawResources t) where
    mempty = RawResources
        { ccdMechanicalCost = mempty
        , ccdBiologicalCost = mempty
        , ccdChemicalCost = mempty
        }

Planet json
    name Text
    position Int
    starSystemId StarSystemId
    ownerId FactionId Maybe
    gravity Double
    SystemPosition starSystemId position
    deriving Show

PlanetReport json
    planetId PlanetId
    ownerId  FactionId Maybe
    starSystemId StarSystemId
    name Text Maybe
    position Int Maybe
    gravity Double Maybe
    factionId FactionId
    date Int
    deriving Show


data CollatedPlanetReport = CollatedPlanetReport
    { cprPlanetId :: Key Planet
    , cprSystemId :: Key StarSystem
    , cprOwnerId  :: Maybe (Key Faction)
    , cprName     :: Maybe Text
    , cprPosition :: Maybe Int
    , cprGravity  :: Maybe Double
    , cprDate     :: Int
    } deriving Show


-- | Class to transform a report stored in db to respective collated report
class ReportTransform a b where
    fromReport :: a -> b

instance ReportTransform PlanetReport CollatedPlanetReport where
    fromReport report =
	CollatedPlanetReport (planetReportPlanetId report)
			     (planetReportStarSystemId report)
			     (planetReportOwnerId report)
			     (planetReportName report)
			     (planetReportPosition report)
			     (planetReportGravity report)
			     (planetReportDate report)


instance Semigroup CollatedPlanetReport where
    (<>) a b = CollatedPlanetReport (cprPlanetId a)
				    (cprSystemId a)
				    (cprOwnerId a <|> cprOwnerId b)
				    (cprName a <|> cprName b)
				    (cprPosition a <|> cprPosition b)
				    (cprGravity a <|> cprGravity b)
				    (max (cprDate a) (cprDate b))

instance Monoid CollatedPlanetReport where
    mempty = CollatedPlanetReport (toSqlKey 0) (toSqlKey 0) Nothing Nothing Nothing Nothing 0


-- | Class to indicate if two reports are about same entity
class Grouped a where
    sameGroup :: a -> a -> Bool

instance Grouped PlanetReport where
    sameGroup a b =
	planetReportPlanetId a == planetReportPlanetId b


-- | Combine list of reports and form a single collated report
--   Resulting report will have facts from the possibly partially empty reports
--   If a fact is not present for a given field, Nothing is left there
collateReport :: (Monoid a, ReportTransform b a) => [b] -> a
collateReport reports = mconcat (map fromReport reports)


-- | Combine list of reports and form a list of collated reports
--   Each reported entity is given their own report
collateReports :: (Grouped b, Monoid a, ReportTransform b a) => [b] -> [a]
collateReports [] = []
collateReports s@(x:_) = collateReport itemsOfKind : collateReports restOfItems
    where split = span (sameGroup x) s
	  itemsOfKind = fst split
	  restOfItems = snd split


$(deriveJSON defaultOptions {fieldLabelModifier = drop 3} ''CollatedPlanetReport)

getApiPlanetR :: Key Planet -> Handler Value
getApiPlanetR planetId = do
    (_, _, fId) <- apiRequireFaction
    loadedPlanetReports <- runDB $ selectList [ PlanetReportPlanetId ==. planetId
					      , PlanetReportFactionId ==. fId ] [ Asc PlanetReportDate ]
    let planetReport = collateReport $ map entityVal loadedPlanetReports :: CollatedPlanetReport
    return $ toJSON planetReport


Star json
    name Text
    starSystemId StarSystemId
    spectralType SpectralType
    luminosityClass LuminosityClass


data LuminosityClass = Iap | Ia | Iab | Ib | II | III | IV | V | VI | VII
    deriving (Show, Read, Eq)
derivePersistField "LuminosityClass"

    radToDeg :: Floating a => a -> a
    degToRad :: Floating a => a -> a
    clamp :: Float -> Float
    day :: Int -> Int -> Int -> Float -> Day Float
    longitudeOfAscendingNode :: Orbit body center => body -> center -> Day d -> LongAscNode body center
    inclinationToEcliptic :: Orbit body center => body -> center -> Day d -> InclToEcl body center
    argumentOfPeriapsis :: Orbit body center => body -> center -> Day d -> ArgPeri body center
    semiMajorAxis :: Orbit body center => body -> center -> Day d -> SemiMajor body center
    eccentricity :: Orbit body center => body -> center -> Day d -> Ecc body center
    meanAnomaly :: Orbit body center => body -> center -> Day d -> MeanAno body center
    eccAnomaly :: MeanAno a b -> Ecc a b -> EccAnomaly a b
    trueAnomaly :: EccAnomaly a b -> Ecc a b -> TrueAnomaly a b
    dist :: EccAnomaly a b -> Ecc a b -> SemiMajor a b -> Distance a b
    toEclCoord :: TrueAnomaly a b -> Distance a b -> LongAscNode a b -> ArgPeri a b -> InclToEcl a b -> EclCoord a b
    toEqCoordinates :: EclCoord body Earth -> Day Float -> EqCoord body

In-Depth Series

Haskell

Intro

Opinion based on traits

Opinion based on relations

Opinion report

Note about incorrectness

In closing

Background

Equality

Hierarchy between type classes

Writing generic code

In closing

Major parts

Designing a vehicle

Finally

Example

In closing

Intro

Server API

Simulation

Research point production

Updating progress

Available research

Background

Implementation

Data types

Tech tree

concrete types

ad hoc polymorphism

parametrized functions

using functions

functions as types

anonymous functions

Overview of simulation

More mapping

Recursion

More tools

Even more tools

Finding tools

Functor

Applicative

Intro

Data types and Database

Kragii attack, redux

Other uses and further plans

Intro

Data types

Database

Extra

Intro

Loading

Making choice

Resolving event

Handling events during simulation

Intro

Server interface

Database

Domain objects

Turning Articles into JSON

Sideshow: IconMapper

Back to JSON

Time to put it all together