AsciiLock.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 {-# LANGUAGE TupleSections #-}
  12
  13 module AsciiLock (lockToAscii, lockOfAscii, stateToAscii
  14     , readAsciiLockFile, writeAsciiLockFile, monochromeOTileChar) where
  15
  16 import           Control.Applicative
  17 import           Control.Arrow       ((&&&))
  18 import           Control.Monad
  19 import           Data.Char           (toUpper)
  20 import           Data.Function       (on)
  21 import           Data.List
  22 import           Data.Map            (Map)
  23 import qualified Data.Map            as Map
  24 import           Data.Maybe
  25 import           Data.Traversable    as T
  26 import qualified Data.Vector         as Vector
  27 import           Safe                (maximumBound)
  28
  29 import           BoardColouring
  30 import           CVec
  31 import           Frame
  32 import           GameState
  33 import           GameStateTypes
  34 import           Hex
  35 import           Lock
  36 import           Mundanities
  37 import           Physics
  38 import           Util
  39
  40
  41 type AsciiLock = [String]
  42
  43 lockToAscii :: Lock -> AsciiLock
  44 lockToAscii = stateToAscii . snd
  45
  46 stateToAscii :: GameState -> AsciiLock
  47 stateToAscii st =
  48     let colouring = boardColouring st (ppidxs st) Map.empty
  49     in boardToAscii colouring . stateBoard $ st
  50
  51 lockOfAscii :: AsciiLock -> Maybe Lock
  52 lockOfAscii lines = do
  53     board <- asciiToBoard lines
  54     let size = maximumBound 0 $ hx . (-^origin) <$> Map.keys board
  55         frame = BasicFrame size
  56     guard $ size > 0
  57     st <- asciiBoardState frame board
  58     return (frame, st)
  59
  60 boardToAscii :: PieceColouring -> GameBoard -> AsciiLock
  61 boardToAscii colouring board =
  62     let asciiBoard :: Map CVec Char
  63         asciiBoard = Map.mapKeys (hexVec2CVec . (-^origin))
  64             $ monochromeOTileChar colouring <$> board
  65         (miny,maxy) = minmax $ cy <$> Map.keys asciiBoard
  66         (minx,maxx) = minmax $ cx <$> Map.keys asciiBoard
  67         asciiBoard' = Map.mapKeys (-^CVec miny minx) asciiBoard
  68     in [ [ Map.findWithDefault ' ' (CVec y x) asciiBoard'
  69             | x <- [0..(maxx-minx)] ]
  70         | y <- [0..(maxy-miny)] ]
  71
  72 asciiToBoard :: AsciiLock -> Maybe GameBoard
  73 asciiToBoard lines =
  74     let asciiBoard :: Map CVec Char
  75         asciiBoard = Map.fromList [(CVec y x,ch)
  76             | (line,y) <- zip lines [0..]
  77             , (ch,x) <- zip line [0..]
  78             , ch `notElem` "\t\r\n "]
  79         (miny,maxy) = minmax $ cy <$> Map.keys asciiBoard
  80         midy = miny+(maxy-miny)`div`2
  81         midline = filter ((==midy).cy) $ Map.keys asciiBoard
  82         (minx,maxx) = minmax $ cx <$> midline
  83         centre = CVec midy (minx+(maxx-minx)`div`2)
  84     in Map.mapKeys ((+^origin) . cVec2HexVec . (-^centre))
  85         <$> T.mapM monoToOTile asciiBoard
  86
  87 asciiBoardState :: Frame -> GameBoard -> Maybe GameState
  88 asciiBoardState frame board =
  89     let addPreBase st = foldr addpp st (replicate 6 $ PlacedPiece origin $ Block [])
  90         addBase st = foldr addBaseOT st $ Map.toList $
  91             Map.filter (isBaseTile.snd) board
  92         isBaseTile (BlockTile _)  = True
  93         isBaseTile (PivotTile _)  = True
  94         isBaseTile HookTile       = True
  95         isBaseTile (WrenchTile _) = True
  96         isBaseTile BallTile       = True
  97         isBaseTile _              = False
  98         addBaseOT :: (HexPos,(PieceIdx,Tile)) -> GameState -> GameState
  99         addBaseOT (pos,(o,BlockTile [])) = addBlockPos o pos
 100         addBaseOT (pos,(-1,t)) = addpp $ PlacedPiece pos $ basePieceOfTile t
 101         addBaseOT _ = error "owned non-block tile in AsciiLock.asciiBoardState"
 102         basePieceOfTile (PivotTile _) = Pivot []
 103         basePieceOfTile HookTile = Hook hu NullHF
 104         basePieceOfTile (WrenchTile _) = Wrench zero
 105         basePieceOfTile BallTile = Ball
 106         basePieceOfTile _ = error "Unexpected tile in AsciiLock.asciiBoardState"
 107         componentifyNew st = foldr ((fst.).componentify) st $ filter (/=0) $ ppidxs st
 108         -- | we assume that the largest wholly out-of-bounds block is the frame
 109         setFrame st = fromMaybe st $ do
 110             (idx,pp) <- listToMaybe $ fst <$> sortBy (flip compare `on` snd)
 111                     [ ((idx,pp),length vs)
 112                     | (idx,pp) <- enumVec $ placedPieces st
 113                     , let fp = plPieceFootprint pp
 114                     , not $ null fp
 115                     , not $ any (inBounds frame) fp
 116                     , Block vs <- [placedPiece pp]
 117                     ]
 118             return $ delPiece idx $ setpp 0 pp st
 119         baseSt = setFrame . componentifyNew . addBase . addPreBase $ GameState Vector.empty []
 120
 121         baseBoard = stateBoard baseSt
 122         addAppendages :: GameState -> Maybe GameState
 123         addAppendages st = foldM addAppendageOT st $ Map.toList $
 124             Map.filter (not.isBaseTile.snd) board
 125         addAppendageOT st (pos,(-1,ArmTile dir _)) =
 126             let rpos = (neg dir+^pos)
 127             in case Map.lookup rpos baseBoard of
 128                 Just (idx,PivotTile _) -> Just $ addPivotArm idx pos st
 129                 Just (idx,HookTile) -> Just $ setpp idx (PlacedPiece rpos (Hook dir NullHF)) st
 130                 _ -> Nothing
 131         addAppendageOT st (pos,(-1,SpringTile _ dir)) =
 132             let rpos = (neg dir+^pos)
 133             in case Map.lookup rpos baseBoard of
 134                 Just (_,SpringTile _ _) -> Just st
 135                 Just _ -> do
 136                     (_,epos) <- castRay pos dir baseBoard
 137                     let twiceNatLen = sum [ extnValue extn
 138                             | i <- [1..hexLen (epos-^rpos)-1]
 139                             , let pos' = i*^dir+^rpos
 140                             , Just (_,SpringTile extn _) <- [ Map.lookup pos' board ] ]
 141                         extnValue Compressed = 4
 142                         extnValue Relaxed    = 2
 143                         extnValue Stretched  = 1
 144                         Just root = posLocus baseSt rpos
 145                         Just end = posLocus baseSt epos
 146                     Just $ flip addConn st $ Connection root end $ Spring dir $ twiceNatLen`div`2
 147                 _ -> Just st
 148         addAppendageOT _ _ = Nothing
 149     in addAppendages baseSt
 150
 151 monochromeOTileChar :: PieceColouring -> OwnedTile -> Char
 152 monochromeOTileChar colouring (idx,BlockTile _) =
 153     case Map.lookup idx colouring of
 154         Just 1 -> '%'
 155         Just 2 -> '"'
 156         Just 3 -> '&'
 157         Just 4 -> '~'
 158         _      -> '#'
 159 monochromeOTileChar _ (_,t) = monochromeTileChar t
 160 monochromeTileChar :: Tile -> Char
 161 monochromeTileChar (PivotTile _) = 'o'
 162 monochromeTileChar (ArmTile dir _)
 163     | dir == hu = '-'
 164     | dir == hv = '\\'
 165     | dir == hw = '/'
 166     | dir == neg hu = '.'
 167     | dir == neg hv = '`'
 168     | dir == neg hw = '\''
 169 monochromeTileChar HookTile = '@'
 170 monochromeTileChar (WrenchTile _) = '*'
 171 monochromeTileChar BallTile = 'O'
 172 monochromeTileChar (SpringTile extn dir)
 173     | dir == hu = case extn of
 174         Stretched  -> 's'
 175         Relaxed    -> 'S'
 176         Compressed -> '$'
 177     | dir == hv = case extn of
 178         Stretched  -> 'z'
 179         Relaxed    -> 'Z'
 180         Compressed -> '5'
 181     | dir == hw = case extn of
 182         Stretched  -> '('
 183         Relaxed    -> '['
 184         Compressed -> '{'
 185     | dir == neg hu = case extn of
 186         Stretched  -> 'c'
 187         Relaxed    -> 'C'
 188         Compressed -> 'D'
 189     | dir == neg hv = case extn of
 190         Stretched  -> ')'
 191         Relaxed    -> ']'
 192         Compressed -> '}'
 193     | dir == neg hw = case extn of
 194         Stretched  -> '1'
 195         Relaxed    -> '7'
 196         Compressed -> '9'
 197 monochromeTileChar _ = '?'
 198 monoToOTile :: Char -> Maybe OwnedTile
 199 monoToOTile '#' = Just (1,BlockTile [])
 200 monoToOTile '%' = Just (2,BlockTile [])
 201 monoToOTile '"' = Just (3,BlockTile [])
 202 monoToOTile '&' = Just (4,BlockTile [])
 203 monoToOTile '~' = Just (5,BlockTile [])
 204 monoToOTile ch  = (-1,) <$> monoToTile ch
 205 monoToTile :: Char -> Maybe Tile
 206 monoToTile 'o'  = Just $ PivotTile zero
 207 monoToTile '-'  = Just $ ArmTile hu False
 208 monoToTile '\\' = Just $ ArmTile hv False
 209 monoToTile '/'  = Just $ ArmTile hw False
 210 monoToTile '.'  = Just $ ArmTile (neg hu) False
 211 monoToTile '`'  = Just $ ArmTile (neg hv) False
 212 monoToTile '\'' = Just $ ArmTile (neg hw) False
 213 monoToTile '@'  = Just HookTile
 214 monoToTile '*'  = Just $ WrenchTile zero
 215 monoToTile 'O'  = Just BallTile
 216 monoToTile 's'  = Just $ SpringTile Stretched hu
 217 monoToTile 'S'  = Just $ SpringTile Relaxed hu
 218 monoToTile '$'  = Just $ SpringTile Compressed hu
 219 monoToTile 'z'  = Just $ SpringTile Stretched hv
 220 monoToTile 'Z'  = Just $ SpringTile Relaxed hv
 221 monoToTile '5'  = Just $ SpringTile Compressed hv
 222 monoToTile '('  = Just $ SpringTile Stretched hw
 223 monoToTile '['  = Just $ SpringTile Relaxed hw
 224 monoToTile '{'  = Just $ SpringTile Compressed hw
 225 monoToTile 'c'  = Just $ SpringTile Stretched (neg hu)
 226 monoToTile 'C'  = Just $ SpringTile Relaxed (neg hu)
 227 monoToTile 'D'  = Just $ SpringTile Compressed (neg hu)
 228 monoToTile ')'  = Just $ SpringTile Stretched (neg hv)
 229 monoToTile ']'  = Just $ SpringTile Relaxed (neg hv)
 230 monoToTile '}'  = Just $ SpringTile Compressed (neg hv)
 231 monoToTile '1'  = Just $ SpringTile Stretched (neg hw)
 232 monoToTile '7'  = Just $ SpringTile Relaxed (neg hw)
 233 monoToTile '9'  = Just $ SpringTile Compressed (neg hw)
 234 monoToTile _    = Nothing
 235
 236 minmax :: Ord a => [a] -> (a,a)
 237 minmax = minimum &&& maximum
 238
 239 solutionToAscii :: Solution -> String
 240 solutionToAscii = map pmToAscii
 241
 242 dirChar :: HexVec -> Char
 243 dirChar dir
 244     | dir == hu = 'l'
 245     | dir == neg hu = 'h'
 246     | dir == hv = 'y'
 247     | dir == neg hv = 'n'
 248     | dir == hw = 'b'
 249     | dir == neg hw = 'u'
 250     | otherwise = '.'
 251 pmToAscii :: PlayerMove -> Char
 252 pmToAscii (HookPush dir)    = dirChar dir
 253 pmToAscii (WrenchPush dir)  = toUpper $ dirChar dir
 254 pmToAscii (HookTorque 1)    = '+'
 255 pmToAscii (HookTorque (-1)) = '-'
 256 pmToAscii _                 = '.'
 257
 258 solutionOfAscii :: String -> Maybe Solution
 259 solutionOfAscii = mapM pmOfAscii
 260
 261 pmOfAscii :: Char -> Maybe PlayerMove
 262 pmOfAscii 'l' = Just $ HookPush hu
 263 pmOfAscii 'y' = Just $ HookPush hv
 264 pmOfAscii 'b' = Just $ HookPush hw
 265 pmOfAscii 'h' = Just . HookPush $ neg hu
 266 pmOfAscii 'n' = Just . HookPush $ neg hv
 267 pmOfAscii 'u' = Just . HookPush $ neg hw
 268 pmOfAscii 'L' = Just $ WrenchPush hu
 269 pmOfAscii 'Y' = Just $ WrenchPush hv
 270 pmOfAscii 'B' = Just $ WrenchPush hw
 271 pmOfAscii 'H' = Just . WrenchPush $ neg hu
 272 pmOfAscii 'N' = Just . WrenchPush $ neg hv
 273 pmOfAscii 'U' = Just . WrenchPush $ neg hw
 274 pmOfAscii '+' = Just $ HookTorque 1
 275 pmOfAscii '-' = Just . HookTorque $ -1
 276 pmOfAscii '.' = Just NullPM
 277 pmOfAscii _   = Nothing
 278
 279 readAsciiLockFile :: FilePath -> IO (Maybe Lock, Maybe Solution)
 280 readAsciiLockFile path = fromLines <$> readStrings path
 281     where fromLines lines = fromMaybe (lockOfAscii lines, Nothing) $ do
 282             guard $ length lines > 2
 283             let (locklines, [header,solnLine]) = splitAt (length lines - 2) lines
 284             guard $ isPrefixOf "Solution:" header
 285             return (lockOfAscii locklines,
 286                 solutionOfAscii solnLine `mplus` tryRead solnLine)
 287
 288 writeAsciiLockFile :: FilePath -> Maybe Solution -> Lock -> IO ()
 289 writeAsciiLockFile path msoln lock = do
 290     writeStrings path $ lockToAscii lock ++ case msoln of
 291         Nothing   -> []
 292         Just soln -> ["Solution:", solutionToAscii soln]