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