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