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,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,
reverse)
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
charToCUChar :: Char -> CUChar
charToCUChar = toEnum . fromEnum
charToSquare :: Bool -> [(Int,String)] -> CUChar -> CUChar -> CUChar ->
Square
charToSquare isGame rtbl sq rbs ext =
if sq == blackChar then Black
else
case rebus of
Just str -> if isGame then
let str' = if sq == blankChar then []
else [cucharToChar sq]
in Rebus str' style
else Rebus str style
Nothing -> if sq == blankChar then Letter Nothing style
else Letter (Just $ cucharToChar sq) style
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
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)
readBoard :: Bool -> Array Index CUChar -> Array Index CUChar
-> [(Int,String)] -> Array Index CUChar
-> Array Index Square
readBoard isGame bd rbs rtbl ext =
let convChar = charToSquare isGame rtbl in
array (bounds bd)
(map (\(i,c) -> (i,convChar c (rbs ! i) (ext ! i)))
(assocs bd))
boardCharsOut :: Int -> Int -> Ptr CUChar -> IO (Array Index CUChar)
boardCharsOut width height ptr =
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
do cuchars <- peekArray (width*height) ptr
return $ array ((0,0),(width1,height1)) $
(\(_,_,l) -> l) $ foldl' numberFold (0,0,[]) 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
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
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 do
width <- puzGetWidth puz
height <- puzGetHeight puz
let bdChrs = boardCharsOut width height
emptyBd = listArray ((0,0),(width1,height1))
(repeat $ toEnum 0)
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 []
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
solution = readBoard False solChrs rebusChrs rebusTbl
extraChrs
clues :: [(Int,Dir,String)]
clues = numberClues clueStrs grid
return $ Left $
Puzzle {width, height, grid, solution,
title, author, copyright, notes, timer,
clues, locked}
savePuzzle :: String -> Puzzle -> IO (Maybe ErrMsg)
savePuzzle fname (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
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)
withArray userBoard (puzSetGrid puz)
withArray solBoard (puzSetSolution puz)
case extrasBoard of
Nothing -> return ()
Just b -> withArray b (puzSetExtras puz)
case rebusInfo of
Nothing -> return ()
Just (rtbl,rbd) -> do withArray rbd (puzSetRebus puz)
puzSetRtbl puz rtbl
case locked of
Nothing -> return ()
Just cksum -> puzLockSet puz cksum
puzCksumsCalc puz
puzCksumsCommit puz
cksumChk <- puzCksumsCheck puz
if not cksumChk
then return $ Just "Internal Error: Checksum calculation failed."
else
do sz <- puzSize puz
allocaArray sz
(\ ptr ->
do saveChk <- puzSave puz ptr sz
if not saveChk
then return $ Just "Internal Error: puzSave failed."
else do handle <- openFile fname WriteMode
hPutBuf handle ptr sz
hClose handle
return Nothing)
stringCksum :: String -> IO CUShort
stringCksum s = puzCksumString s (length s)