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