Metagame.hs

   1 -- This file is part of Intricacy
   2 -- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 module Metagame where
  12
  13 import           Control.Applicative
  14 import           Control.Monad
  15 import           Data.Array
  16 import           Data.Binary
  17 import           Data.Char
  18 import           Data.List           (delete)
  19 import           Data.Maybe
  20
  21 import           GameStateTypes
  22 import           Lock
  23
  24 notesNeeded = 3
  25 maxLocks = 3
  26
  27 type Codename = String
  28
  29 validCodeName name = length name == 3 && all validChar name
  30     where validChar c = isAscii c && isPrint c && not (isLower c) && c /= ' '
  31
  32 data UserInfo = UserInfo {codename::Codename, userLocks::Array LockIndex (Maybe LockInfo), notesRead::[NoteInfo]}
  33     deriving (Eq, Ord, Show, Read)
  34
  35 initUserInfo name = UserInfo name (array (0,maxLocks-1) $ zip [0..maxLocks-1] (repeat Nothing)) []
  36
  37 data LockInfo = LockInfo {lockSpec::LockSpec, public::Bool, notesSecured::[NoteInfo], lockSolutions::[NoteInfo], accessedBy::[Codename]}
  38     deriving (Eq, Ord, Show, Read)
  39
  40 initLockInfo ls = LockInfo ls False [] [] []
  41
  42 data NoteInfo = NoteInfo {noteAuthor::Codename, noteBehind::Maybe ActiveLock, noteOn::ActiveLock}
  43     deriving (Eq, Ord, Show, Read)
  44
  45 data ActiveLock = ActiveLock {lockOwner::Codename, lockIndex :: LockIndex}
  46     deriving (Eq, Ord, Show, Read)
  47
  48 data AccessedReason = AccessedPrivyRead | AccessedPrivySolved {noteReadByOwner::Bool} | AccessedEmpty | AccessedPub
  49     deriving (Eq, Ord, Show, Read)
  50 winsPoint :: AccessedReason -> Bool
  51 winsPoint (AccessedPrivySolved True) = False
  52 winsPoint _                          = True
  53
  54 getAccessInfo :: UserInfo -> UserInfo -> [Maybe AccessedReason]
  55 getAccessInfo accessedUInfo accessorUInfo =
  56     let accessor = codename accessorUInfo
  57         mlinfos = elems $ userLocks accessedUInfo
  58         accessedSlot = maybe accessedAllExisting accessedLock
  59         accessedAllExisting = all (maybe True accessedLock) mlinfos
  60         accessedLock linfo = public linfo || accessor `elem` accessedBy linfo
  61     in map (maybe
  62             (if accessedAllExisting then Just AccessedEmpty else Nothing)
  63             (\linfo -> if public linfo then Just AccessedPub else
  64                 if not $ accessedLock linfo then Nothing else Just $
  65                     if countRead accessorUInfo linfo >= notesNeeded then AccessedPrivyRead
  66                         else AccessedPrivySolved $ not.null $
  67                             [ n
  68                             | n <- lockSolutions linfo
  69                             , noteAuthor n == accessor
  70                             , isNothing (noteBehind n) || n `elem` notesRead accessedUInfo ]))
  71         mlinfos
  72
  73 countRead :: UserInfo -> LockInfo -> Int
  74 countRead reader tlock = fromIntegral $ length
  75         $ filter (\n -> (isNothing (noteBehind n) || n `elem` notesRead reader)
  76             && noteAuthor n /= codename reader)
  77         $ lockSolutions tlock
  78
  79 data UserInfoDelta
  80     = AddRead NoteInfo
  81     | DelRead NoteInfo
  82     | PutLock LockSpec LockIndex
  83     | LockDelta LockIndex LockDelta
  84     deriving (Eq, Ord, Show, Read)
  85 data LockDelta
  86     = SetPubNote NoteInfo
  87     | AddSecured NoteInfo
  88     | DelSecured NoteInfo
  89     | AddSolution NoteInfo
  90     | AddAccessed Codename
  91     | SetPublic
  92     deriving (Eq, Ord, Show, Read)
  93
  94 data Undeclared = Undeclared Solution LockSpec ActiveLock
  95     deriving (Eq, Ord, Show, Read)
  96
  97 -- | permanent serial number of a lock
  98 type LockSpec = Int
  99
 100 -- | which of a user's three locks (0,1, or 2)
 101 type LockIndex = Int
 102
 103 -- | solved state
 104 type Hint = GameState
 105
 106 lockIndexChar :: LockIndex -> Char
 107 lockIndexChar i = toEnum $ i + fromEnum 'A'
 108
 109 charLockIndex c = fromEnum (toUpper c) - fromEnum 'A'
 110
 111 alockStr :: ActiveLock -> String
 112 alockStr (ActiveLock name idx) = name ++ [':',lockIndexChar idx]
 113
 114 applyDeltas :: UserInfo -> [UserInfoDelta] -> UserInfo
 115 applyDeltas = foldr applyDelta
 116
 117 applyDelta :: UserInfoDelta -> UserInfo -> UserInfo
 118 applyDelta (AddRead n) info = info { notesRead = n:notesRead info }
 119 applyDelta (DelRead n) info = info { notesRead = delete n (notesRead info) }
 120 applyDelta (PutLock ls li) info = info { userLocks = userLocks info // [(li, Just $ initLockInfo ls)] }
 121 applyDelta (LockDelta li ld) info =
 122     info { userLocks = userLocks info // [(li, fmap (applyLockDelta ld) (userLocks info ! li))] }
 123 applyLockDelta (SetPubNote n) lockinfo = lockinfo { lockSolutions = map
 124     (\n' -> if n' == n then n {noteBehind=Nothing} else n') (lockSolutions lockinfo) }
 125 applyLockDelta (AddSecured n) lockinfo = lockinfo { notesSecured = n:notesSecured lockinfo }
 126 applyLockDelta (DelSecured n) lockinfo = lockinfo { notesSecured = delete n $ notesSecured lockinfo }
 127 applyLockDelta (AddSolution n) lockinfo = lockinfo { lockSolutions = n:lockSolutions lockinfo }
 128 applyLockDelta (AddAccessed name) lockinfo = lockinfo { accessedBy = name:delete name (accessedBy lockinfo) }
 129 applyLockDelta SetPublic lockinfo = lockinfo { public = True, lockSolutions = [], accessedBy = [], notesSecured = []}
 130
 131 instance Binary UserInfo where
 132     put (UserInfo name locks notes) = put name >> put locks >> put notes
 133     get = liftM3 UserInfo get get get
 134
 135 instance Binary UserInfoDelta where
 136     put (AddRead note)    = put (0::Word8) >> put note
 137     put (DelRead note)    = put (1::Word8) >> put note
 138     put (PutLock ls li)   = put (2::Word8) >> put ls >> put li
 139     put (LockDelta li ld) = put (3::Word8) >> put li >> put ld
 140     get = do
 141         tag <- get :: Get Word8
 142         case tag of
 143             0 -> AddRead <$> get
 144             1 -> DelRead <$> get
 145             2 -> PutLock <$> get <*> get
 146             3 -> LockDelta <$> get <*> get
 147
 148 instance Binary LockDelta where
 149     put (SetPubNote note)  = put (0::Word8) >> put note
 150     put (AddSecured note)  = put (1::Word8) >> put note
 151     put (DelSecured note)  = put (2::Word8) >> put note
 152     put (AddSolution note) = put (3::Word8) >> put note
 153     put (AddAccessed name) = put (4::Word8) >> put name
 154     put SetPublic          = put (5::Word8)
 155     get = do
 156         tag <- get :: Get Word8
 157         case tag of
 158             0 -> SetPubNote <$> get
 159             1 -> AddSecured <$> get
 160             2 -> DelSecured <$> get
 161             3 -> AddSolution <$> get
 162             4 -> AddAccessed <$> get
 163             5 -> return SetPublic
 164
 165 instance Binary LockInfo where
 166     put (LockInfo spec pk notes solved accessed) = put spec >> put pk >> put notes >> put solved >> put accessed
 167     get = liftM5 LockInfo get get get get get
 168
 169 instance Binary NoteInfo where
 170     put (NoteInfo author behind on) = put author >> put behind >> put on
 171     get = liftM3 NoteInfo get get get
 172
 173 instance Binary ActiveLock where
 174     put (ActiveLock owner idx) = put owner >> put idx
 175     get = liftM2 ActiveLock get get