module Codec.Game.Puz
(Style (Plain,Circle), Square (Black,Letter,Rebus),
Dir (Across,Down), Puzzle (Puzzle), Index,
width,height,grid,solution,title,author,notes,
copyright,timer,clues,locked,
numberGrid,unlockPuz,bruteForceUnlockPuz,
loadPuzzle,savePuzzle,stringCksum)
where
import Codec.Game.Puz.Internal
import System.IO hiding (hGetContents)
import System.IO.Error
import Foreign.Ptr
import Foreign.C
import Foreign.Marshal.Array
import Data.ByteString hiding (map,foldl,foldl',zip,zipWith,length,find,
all,any,reverse,putStrLn,replicate)
import Data.Array
import Data.List
import Data.Maybe
import Control.Monad
data Style = Plain | Circle
deriving (Eq, Show)
data Square
= Black
| Letter (Maybe Char) Style
| Rebus String Style
deriving (Eq, Show)
data Dir = Across | Down
deriving (Eq, Show)
type Index = (Int,Int)
data Puzzle =
Puzzle { width,height :: Int,
grid,solution :: Array Index Square,
title,author,notes,copyright :: String,
timer :: Maybe (Int,Bool),
clues :: [(Int,Dir,String)],
locked :: Maybe CUShort
}
deriving (Show)
type ErrMsg = String
blankChar,blackChar,extrasBlankChar :: CUChar
blackChar = fromIntegral (fromEnum '.')
blankChar = fromIntegral (fromEnum '-')
extrasBlankChar = toEnum 0
styleMap :: [(CUChar,Style)]
styleMap = [(0,Plain),(128,Circle)]
styleMap' :: [(Style,CUChar)]
styleMap' = map (\(a,b) -> (b,a)) styleMap
charToStyle :: CUChar -> Maybe Style
charToStyle i = lookup i styleMap
styleToChar :: Style -> CUChar
styleToChar s = fromJust $ lookup s styleMap'
orderClues :: (Int,Dir,String) -> (Int,Dir,String) -> Ordering
orderClues (i1,d1,_) (i2,d2,_) =
case compare i1 i2 of
EQ -> case (d1,d2) of
(Across,Down) -> LT
(Down,Across) -> GT
_ -> EQ
c -> c
cucharToChar :: CUChar -> Char
cucharToChar = toEnum . fromEnum
charToSquare :: Bool -> [(Int,String)] -> CUChar -> CUChar -> CUChar
-> Maybe String -> Square
charToSquare isGame rtbl sq rbs ext rusr =
if sq == blackChar then Black
else
if isGame then
case (rusr,rebus) of
(Just str, _) -> Rebus str style
(_, Just _) ->
let str' = if sq == blankChar then [] else [cucharToChar sq]
in Rebus str' style
(_,_) -> dflt
else
case rebus of
Just str -> Rebus str style
Nothing -> dflt
where
style = case charToStyle ext of
Just s -> s
Nothing -> Plain
rebus = if rbs == 0 then Nothing else
case lookup (fromIntegral rbs) rtbl of
Nothing -> error ("Puzzle file contains ill-formed " ++
"rebus section")
Just str -> Just str
dflt = if sq == blankChar then Letter Nothing style
else Letter (Just $ cucharToChar sq) style
squareToBoardChar :: Square -> CUChar
squareToBoardChar Black = blackChar
squareToBoardChar (Letter m _) = case m of
Nothing -> blankChar
Just c -> charToCUChar c
squareToBoardChar (Rebus m _) = case m of
[] -> blankChar
(c:_) -> charToCUChar c
squareToExtrasChar :: Square -> CUChar
squareToExtrasChar Black = styleToChar Plain
squareToExtrasChar (Letter _ s) = styleToChar s
squareToExtrasChar (Rebus _ s) = styleToChar s
gridToExtras :: [Square] -> Maybe [CUChar]
gridToExtras sqs =
let es = map squareToExtrasChar sqs
ps = styleToChar Plain
in if all (ps==) es then Nothing else Just es
gridToRebus :: [Square] -> Maybe ([(String,Int)],[CUChar])
gridToRebus sqs =
case foldl folder (0,[],[]) sqs of
(0,_,_) -> Nothing
(_,rtbl,is) -> Just (reverse rtbl, reverse is)
where
folder :: (Int,[(String,Int)],[CUChar]) -> Square ->
(Int,[(String,Int)],[CUChar])
folder (n,rtbl,is) sq =
case sq of
Black -> (n,rtbl,extrasBlankChar:is)
Letter _ _ -> (n,rtbl,extrasBlankChar:is)
Rebus s _ -> case lookup s rtbl of
Nothing -> (n+1, (s,n):rtbl, (toEnum (n+1)):is)
Just n' -> (n, rtbl, (toEnum (n'+1)):is)
gridToRusr :: [Square] -> Maybe [Maybe String]
gridToRusr sqs =
if any isJust strs then Just strs else Nothing
where
strs :: [Maybe String]
strs = map (\sq -> case sq of {Rebus s _ -> Just s; _ -> Nothing}) sqs
readBoard :: Bool -> Array Index CUChar -> Array Index CUChar
-> [(Int,String)] -> Array Index CUChar
-> Array Index (Maybe String)
-> Array Index Square
readBoard isGame bd rbs rtbl ext rusr =
let convChar = charToSquare isGame rtbl in
array (bounds bd)
(map (\(i,c) -> (i,convChar c (rbs ! i) (ext ! i) (rusr ! i)))
(assocs bd))
listToBoard :: Int -> Int -> [a] -> Array Index a
listToBoard width height la =
let
numberFold :: (Int,Int,[(Index,a)]) -> a ->
(Int,Int,[(Index,a)])
numberFold (x,y,l) sq =
let (x',y') = if x+1 == width then (0,y+1) else (x+1,y) in
(x',y',(((x,y),sq):l))
in
array ((0,0),(width1,height1)) $ (\(_,_,l) -> l) $
foldl' numberFold (0,0,[]) la
boardCharsOut :: Int -> Int -> Ptr CUChar -> IO (Array Index CUChar)
boardCharsOut width height ptr =
do cuchars <- peekArray (width*height) ptr
return $ listToBoard width height cuchars
numberClues :: [String] -> Array Index Square -> [(Int,Dir,String)]
numberClues cls bd =
zipWith (\(a,b) c -> (a,b,c)) (findclues 1 (0,0)) cls
where
(_,(xmax,ymax)) = bounds bd
findclues :: Int -> Index -> [(Int,Dir)]
findclues n (x,y) =
if black then rec else
case (asq,bsq) of
(True,True) -> (n,Across) : (n,Down) : rec
(True,False) -> (n,Across) : rec
(False,True) -> (n,Down) : rec
(False,False) -> rec
where
black = bd ! (x,y) == Black
asq = x == 0 || bd ! (x1,y) == Black
bsq = y == 0 || bd ! (x,y1) == Black
nextind = if x == xmax then
if y == ymax then Nothing else Just (0,y+1)
else Just (x+1,y)
nextnum = if (not black) && (asq || bsq) then n+1 else n
rec = case nextind of Nothing -> []
Just ind -> findclues nextnum ind
fromRusr :: Int -> Ptr (Ptr CUChar) -> IO [Maybe String]
fromRusr len arr =
do ptrs <- peekArray len arr
mapM (\ptr -> if ptr == nullPtr then return Nothing
else do chrs <- peekArray0 0 ptr
return $ Just $ map cucharToChar chrs)
ptrs
fromPuz :: Puz -> IO Puzzle
fromPuz puz =
do width <- puzGetWidth puz
height <- puzGetHeight puz
let bdChrs = boardCharsOut width height
emptyBd = listArray ((0,0),(width1,height1)) (repeat $ toEnum 0)
bdSize = width*height
nothings = replicate bdSize Nothing
gridChrs <- puzGetGrid puz >>= bdChrs
solChrs <- puzGetSolution puz >>= bdChrs
title <- puzGetTitle puz
author <- puzGetAuthor puz
copyright <- puzGetCopyright puz
notes <- puzGetNotes puz
hasTimer <- puzHasTimer puz
timer <- if hasTimer
then liftM2 (\x y -> Just (x,y))
(puzGetTimerElapsed puz)
(puzGetTimerStopped puz)
else return Nothing
hasRebus <- puzHasRebus puz
rebusChrs <- if hasRebus then puzGetRebus puz >>= bdChrs
else return emptyBd
rebusTbl <- if hasRebus then puzGetRtbl puz else return []
hasRusr <- puzHasRusr puz
rusrList <- if hasRusr then puzGetRusr puz >>= fromRusr bdSize
else return nothings
let rusrBoard = listToBoard width height rusrList
hasExtras <- puzHasExtras puz
extraChrs <- if hasExtras then puzGetExtras puz >>= bdChrs
else return emptyBd
clueCount <- puzGetClueCount puz
clueStrs <- mapM (puzGetClue puz) [0..(clueCount1)]
isScrambled <- puzIsLockedGet puz
locked <- if isScrambled then liftM Just $ puzLockedCksumGet puz
else return Nothing
let grid, solution :: Array Index Square
grid = readBoard True gridChrs rebusChrs rebusTbl extraChrs
rusrBoard
solution = readBoard False solChrs rebusChrs rebusTbl extraChrs
rusrBoard
clues :: [(Int,Dir,String)]
clues = numberClues clueStrs grid
return $
Puzzle {width, height, grid, solution, title, author, copyright,
notes, timer, clues, locked}
toPuz :: Puzzle -> IO (Either ErrMsg Puz)
toPuz (Puzzle {width, height, grid, solution, title, author, notes,
copyright, timer, clues, locked}) =
let clueCount = length clues
clueStrs = map (\(_,_,s) -> s) (sortBy orderClues clues)
gridSqs,solSqs :: [Square]
gridSqs = elems (ixmap ((0,0),(height1,width1))
(\(a,b) -> (b,a)) grid)
solSqs = elems (ixmap ((0,0),(height1,width1))
(\(a,b) -> (b,a)) solution)
userBoard,solBoard :: [CUChar]
userBoard = map squareToBoardChar gridSqs
solBoard = map squareToBoardChar solSqs
extrasBoard :: Maybe [CUChar]
extrasBoard = gridToExtras solSqs
rebusInfo :: Maybe ([(String,Int)],[CUChar])
rebusInfo = gridToRebus solSqs
rusrInfo :: Maybe [Maybe String]
rusrInfo = gridToRusr gridSqs
in
do puz <- puzCreate
puzSetWidth puz width
puzSetHeight puz height
puzSetTitle puz title
puzSetAuthor puz author
puzSetNotes puz notes
puzSetCopyright puz copyright
case timer of
Nothing -> return ()
Just (e,s) -> puzSetTimer puz e s
puzSetClueCount puz clueCount
mapM_ (\(n,c) -> puzSetClue puz n c) (zip [0..] clueStrs)
withArray0 0 userBoard (puzSetGrid puz)
withArray0 0 solBoard (puzSetSolution puz)
case extrasBoard of
Nothing -> return ()
Just b -> withArray0 0 b (puzSetExtras puz)
case rebusInfo of
Nothing -> return ()
Just (rtbl,rbd) -> do withArray0 0 rbd (puzSetRebus puz)
puzSetRtbl puz rtbl
case rusrInfo of
Nothing -> return ()
Just rusr -> puzSetRusr puz rusr
case locked of
Nothing -> return ()
Just cksum -> puzLockSet puz cksum
puzCksumsCalc puz
puzCksumsCommit puz
cksumChk <- puzCksumsCheck puz
return $
if not cksumChk
then Left "Internal Error: Checksum calculation failed."
else Right puz
numberGrid :: Array Index Square -> Array Index (Maybe Int)
numberGrid grid =
array (bounds grid) bd_ass
where
indexCompare :: Index -> Index -> Ordering
indexCompare (i1,i2) (j1,j2) = case compare i2 j2 of
LT -> LT
GT -> GT
EQ -> compare i1 j1
ass :: [(Index,Square)]
ass = sortBy (\(i,_) (j,_) -> indexCompare i j) $ assocs grid
isEmpty :: Index -> Bool
isEmpty i = case lookup i ass of
Nothing -> True
Just Black -> True
Just (Letter _ _) -> False
Just (Rebus _ _) -> False
folder :: (Int, [(Index, Maybe Int)]) ->
(Index,Square) ->
(Int, [(Index, Maybe Int)])
folder (ct,ns) (i@(ix,iy),sq) =
let up_e, left_e :: Bool
up_e = isEmpty (ix,iy1)
left_e = isEmpty (ix1,iy)
in
case sq of
Black -> (ct, (i,Nothing) : ns)
Letter _ _ ->
if up_e || left_e
then (ct+1, (i, Just ct) : ns)
else (ct , (i, Nothing) : ns)
Rebus _ _ ->
if up_e || left_e
then (ct+1, (i, Just ct) : ns)
else (ct , (i, Nothing) : ns)
bd_ass :: [(Index, Maybe Int)]
(_,bd_ass) = foldl folder (1,[]) ass
unlockPuz :: Puzzle -> CUShort -> IO (Either ErrMsg Puzzle)
unlockPuz puzzle code =
do epuz <- toPuz puzzle
case epuz of
Left err -> return $ Left err
Right puz ->
do worked <- puzUnlockSolution puz code
if worked
then liftM Right $ fromPuz puz
else return $ Left ( "Code " ++ show code
++ " didn't unlock the puzzle.")
bruteForceUnlockPuz :: Puzzle -> IO (Either ErrMsg (Puzzle,Int))
bruteForceUnlockPuz puzzle =
do epuz <- toPuz puzzle
case epuz of
Left err -> return $ Left err
Right puz ->
do worked <- puzBruteForceUnlock puz
case worked of
Nothing -> return $ Left $
"Sorry, no possible code successfully unlocked this "
++ "puzzle. It may be ill-formed."
Just code -> do puz' <- fromPuz puz
return $ Right (puz',code)
loadPuzzle :: String -> IO (Either Puzzle ErrMsg)
loadPuzzle fname =
do
ehandle <- try (openFile fname ReadMode)
case ehandle of
Left err ->
if isDoesNotExistError err
then return $ Right $ "File " ++ fname ++ " does not exist."
else
if isPermissionError err
then
return $ Right $ "Cannot access file " ++ fname ++
". (permissions error)"
else return $ Right $ "Cannot open " ++ fname
Right handle -> do
size <- liftM fromIntegral $ hFileSize handle
bytestring <- hGetContents handle
hClose handle
let cchars :: [CUChar]
cchars = foldr' (\w cs -> (fromIntegral w) : cs) [] bytestring
mpuz <- withArray cchars (\ar -> puzLoad ar size)
case mpuz of
Nothing -> return $ Right "Ill-formed puzzle"
Just puz ->
(puzCksumsCheck puz >>=
\v -> if not v
then return $ Right "Ill-formed puzzle: bad checksums"
else liftM Left $ fromPuz puz)
savePuzzle :: String -> Puzzle -> IO (Maybe ErrMsg)
savePuzzle fname puzzle =
do mpuz <- toPuz puzzle
case mpuz of
Left err -> return $ Just err
Right puz ->
do sz <- puzSize puz
allocaArray sz
(\ ptr ->
do saveChk <- puzSave puz ptr sz
if not saveChk
then return $ Just "Internal Error: puzSave failed."
else catch
(do handle <- openFile fname WriteMode
hPutBuf handle ptr sz
hClose handle
return Nothing)
(\err -> return $ Just $ show err))
stringCksum :: String -> IO CUShort
stringCksum s = puzCksumString s (length s)