{-# LANGUAGE NamedFieldPuns #-} 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 {- ------ Types ------- -} {-| The 'Style' type enumerates the possible styles of fillable squares. Currently, there are only two: plain squares and circled squares. -} data Style = Plain | Circle deriving (Eq, Show) {-| The 'Square' type represents a square in a puzzle. -} data Square -- | Black squares = Black -- | Standard letter squares, optionally filled in | Letter (Maybe Char) Style -- | Rebus squares, optionally filled in | Rebus String Style deriving (Eq, Show) data Dir = Across | Down deriving (Eq, Show) type Index = (Int,Int) {-| The 'Puzzle' type represents a particular crossword. The crossword's dimensions are specified by 'width' and 'height'. The contents of the puzzle are given by two arrays of 'Square's - 'grid' and 'solution'. The board arrays are in row-major order and are numbered from (0,0) to (width-1,height-1). The 'grid' board represents the current state of play, and as such its squares may be partially or entirely filled in, correctly or incorrectly. The 'solution' board should have the same basic layout as the 'grid' board (in terms of black vs letter squares), and should be entirely filled in. Various other pieces of data about the puzzle are given bu 'title', 'author', 'notes' and 'copyright', all 'String's. There is an optional "timer", which is a number of seconds elapsed and a bool that is true if the timer is stopped and false otherwise. The field 'clues' gives the puzzle's clues. The numbers in this array correspond to the numbering that would appear on the grid. To reconstruct this information, see the 'numberGrid' function. -} 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 {- ------- Constants ------- -} 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' -- how to order clues 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 {- ---- Internal marshalling stuff ---- -} cucharToChar :: CUChar -> Char cucharToChar = toEnum . fromEnum charToCUChar :: Char -> CUChar charToCUChar = toEnum . fromEnum -- The bool is true of this is a game board and false if it is a solution -- board 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 --XXX maybe I should issue some kind of warning 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) -- The first string is the board. The second string is the rebus board -- (or all 0s if none exists). The [(Int,String)] is the rebus table, -- (or an empty list of there aren't any to lookup). The third String -- is the extras board. -- -- The bool should be True if this is a game board and false if it is a -- solution board. 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 -- these guys are in row-major order, so we need to flip 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),(width-1,height-1)) $ (\(_,_,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 -- sq number -> position -> list of places clues are needed 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 ! (x-1,y) == Black bsq = y == 0 || bd ! (x,y-1) == 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 {- ---- Exposed library ---- -} 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,iy-1) left_e = isEmpty (ix-1,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 --- Start by getting internal puz representation 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),(width-1,height-1)) (repeat $ toEnum 0) -- Now get all the raw strings we need from the internal -- puz structure 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..(clueCount-1)] isScrambled <- puzIsLockedGet puz locked <- if isScrambled then liftM Just $ puzLockedCksumGet puz else return Nothing -- we use these strings and the puz data to get everything we -- need to build a Puzzle 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) -- since these arrays are row-major but that's the wrong order for -- libpuz, we flip the indices first, which gets us a list in the -- right order gridSqs,solSqs :: [Square] gridSqs = elems (ixmap ((0,0),(height-1,width-1)) (\(a,b) -> (b,a)) grid) solSqs = elems (ixmap ((0,0),(height-1,width-1)) (\(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 -- set the easy stuff that is marshalled by Internal 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)