{-# LANGUAGE EmptyDataDecls, TypeFamilies #-}
module Ham.Internal.Contest where
import Ham.Log
import Ham.Data (band, Band)
import Data.Sequence as S
import Data.Char (toUpper)
import Data.Text as T
import qualified Data.Map as M
import Data.Proxy
import Data.List as L (groupBy, sortBy)
import Data.Foldable (toList)
import Prelude as P
class Contest a where
type Points a :: *
type Config a :: *
computePoints :: Proxy a -> Config a -> HamLog (Points a)
data FieldDay
data FieldDayPoints = FieldDayPoints { fdpTotal :: Float
, fdpPowerMult :: Float
, fdpBonus :: Float
, fdpQsos :: [(String, [(String, Int)])] } deriving Show
instance Contest FieldDay where
type Points FieldDay = FieldDayPoints
type Config FieldDay = ConfigFieldDay
computePoints _ cfg = do
s <- getQsoSeq
let cw_qsos = S.filter (\a -> _qsoMode a == CW) s
ph_qsos = S.filter (\a -> _qsoMode a == PH || _qsoMode a == FM) s
data_qsos = S.filter (\a -> _qsoMode a == DATA || _qsoMode a == RY) s
cw_points = 2 * fromIntegral (S.length cw_qsos)
ph_points = 1 * fromIntegral (S.length ph_qsos)
data_points = 2 * fromIntegral (S.length data_qsos)
total = (cw_points + ph_points + data_points) * powerMult + bonus
powerMult = fieldDayPowerMultiplier cfg
bonus = fieldDayBonus cfg
return $ FieldDayPoints total powerMult bonus [("CW", qsosByBand' cw_qsos),
("PH", qsosByBand' ph_qsos),
("DATA", qsosByBand' data_qsos)]
qsosByBand' :: Seq Qso -> [(String, Int)]
qsosByBand' qsos = P.map f $ qsosByBand qsos
where
f as@(a:_) = ((show $ band $ _qsoFrequency a), P.length as)
qsosByBand :: Seq Qso -> [[Qso]]
qsosByBand qsos = groups
where groups = L.groupBy (\a b -> band (_qsoFrequency a) == band (_qsoFrequency b)) sortedQsos
sortedQsos = L.sortBy (\a b -> compare (_qsoFrequency a) (_qsoFrequency b)) $ toList qsos
qsosByBand'' :: Seq Qso -> [(Band, [Qso])]
qsosByBand'' qsos = P.map f $ qsosByBand qsos
where f as@(a:_) = ((band $ _qsoFrequency a), as)
fieldDayBonus :: ConfigFieldDay -> Float
fieldDayBonus c = sum [c1,c2,c3,c4,c5,c6,fdOtherBonusPoints c]
where c1 | fdMediaPublicity c = 100
| otherwise = 0
c2 | fdPublicLocation c = 100
| otherwise = 0
c3 | fdPublicInfoTable c = 100
| otherwise = 0
c4 = (fromIntegral $ fdFormalMessages c) * 10
c5 | fdEmergencyPower c = 100
| otherwise = 0
c6 | fdAlternatePower c = 100
| otherwise = 0
fieldDayPowerMultiplier :: ConfigFieldDay -> Float
fieldDayPowerMultiplier c =
case fdPower c of
FD5W -> 5
FD150W -> 2
FDHighPower -> 1
data FieldDayPower = FD5W | FD150W | FDHighPower
data ConfigFieldDay = ConfigFieldDay { fdEmergencyPower :: Bool
, fdPower :: FieldDayPower
, fdMediaPublicity :: Bool
, fdPublicLocation :: Bool
, fdPublicInfoTable :: Bool
, fdFormalMessages :: Int
, fdAlternatePower :: Bool
, fdOtherBonusPoints :: Float
}
state qso = s
where ex = _qsoExchange qso
ws = T.words ex
s | P.length ws >= 2 = T.toUpper $ P.last ws
| otherwise = mempty
countStates qsos = M.size $ M.fromListWith (+) $ P.zip (P.map state qsos) (repeat 1)
naqpPoints :: QsoMode -> HamLog PointsNAQP
naqpPoints mode = do
s <- getQsoSeq
let mode_qsos = S.filter (\a -> _qsoMode a == mode)
qsos_by_band = qsosByBand'' $ mode_qsos s
multipliers_and_qso_count = P.map f qsos_by_band
where f (bd, qsos) =
(bd, fromIntegral $ countStates qsos, fromIntegral $ P.length qsos)
mode_points = P.map (\(bd, mult, n) -> (bd, mult * n)) multipliers_and_qso_count
mode_points_total = P.foldr ((+) . snd) 0 mode_points
return $ PointsNAQP multipliers_and_qso_count mode_points_total
data PointsNAQP = PointsNAQP { pnaqpPointsPerBand :: [(Band, Float, Float)],
pnaqpTotalPoints :: Float } deriving Show
data NAQPCW
instance Contest NAQPCW where
type Points NAQPCW = PointsNAQP
type Config NAQPCW = ()
computePoints _ cfg = naqpPoints CW
data NAQPSSB
instance Contest NAQPSSB where
type Points NAQPSSB = PointsNAQP
type Config NAQPSSB = ()
computePoints _ cfg = naqpPoints PH