module UserInterface (
BuilderCastException(..)
, SudokuUI
, window
, menu
, gameButtons
, cells
, popover
, numberButtons
, inputClear
, inputSolve
, solveButton
, checkButton
, menuButton
, buildSudokuUI
, writePopoverRelativeCell
, solveAll
, solvePopoverRelativeCell
, checkAll
, cellsBindHandlers
, numbersBindHandlers
, gameButtonsBindHandlers
, showMenu
) where
import Control.Concurrent (forkIO, threadDelay)
import Control.Exception
import Control.Monad.IO.Class
import Data.GI.Base
import qualified Data.Text as T
import Data.Typeable
import GI.Gtk
import Paths_hsudoku
import Sudoku.Loader
import Sudoku.Solver
import Sudoku.Type
data BuilderCastException = UnknownIdException String deriving (Show, Typeable)
instance Exception BuilderCastException
type Cell = Button
type Cells = [Cell]
type GameMenu = Widget
data SudokuUI = SudokuUI { window :: Window
, menu :: GameMenu
, gameButtons :: [Button]
, cells :: Cells
, popover :: Popover
, numberButtons :: [Button]
, inputClear :: Button
, inputSolve :: Button
, solveButton :: Button
, checkButton :: Button
, menuButton :: Button
}
buildSudokuUI :: IO SudokuUI
buildSudokuUI = do
uiFile <- T.pack <$> getDataFileName "gui/hsudoku.ui"
(window, builder) <- buildMainWindow "mainWindow" uiFile
menu <- builderGetTyped builder "menu" Widget
gameButtons <- builderGetsTyped builder gameButtonNames Button
cells <- builderGetsTyped builder cellNames Button
popover <- builderGetTyped builder "inputPopover" Popover
numberButtons <- builderGetsTyped builder numberNames Button
inputClear <- builderGetTyped builder "inputClear" Button
inputSolve <- builderGetTyped builder "inputSolve" Button
solveButton <- builderGetTyped builder "solveButton" Button
checkButton <- builderGetTyped builder "checkButton" Button
menuButton <- builderGetTyped builder "menuButton" Button
pure $ SudokuUI window menu gameButtons cells popover
numberButtons inputClear inputSolve solveButton
checkButton menuButton
cellNames :: [T.Text]
cellNames = map (T.pack . (++) "cell") $ map show [1..81]
numberNames :: [T.Text]
numberNames = map (T.pack . (++) "input") $ map show [1..9]
gameButtonNames :: [T.Text]
gameButtonNames = map (T.pack . (++) "game" . show) [Easy ..]
builderGetTyped :: (IsBuilder a, GObject o, MonadIO m) => a -> T.Text -> (ManagedPtr o -> o) -> m o
builderGetTyped builder ident gtype =
liftIO $ do
o <- builderGetObject builder ident
case o of
Just a -> unsafeCastTo gtype a
Nothing -> throw $ UnknownIdException $ T.unpack ident
builderGetsTyped :: (GObject a, IsBuilder b, MonadIO m) => b -> [T.Text] -> (ManagedPtr a -> a) -> m [a]
builderGetsTyped b is t = sequence $ map (\i -> builderGetTyped b i t) is
buildMainWindow :: MonadIO m => T.Text -> T.Text -> m (Window, Builder)
buildMainWindow name path = liftIO $ do
builder <- builderNewFromFile path
window <- builderGetTyped builder name Window
on window #destroy mainQuit
cssFile <- T.pack <$> getDataFileName "gui/theme.css"
windowAddCss window cssFile
pure (window, builder)
windowAddCss :: (MonadIO m, IsWindow a) => a -> T.Text -> m ()
windowAddCss window path = liftIO $ do
screen <- windowGetScreen window
cssProvider <- cssProviderNew
cssProviderLoadFromPath cssProvider path
styleContextAddProviderForScreen screen cssProvider 1000
writeCell :: Cell -> Char -> IO ()
writeCell cell char = #setLabel cell (T.singleton char)
writePopoverRelativeCell :: Popover -> Char -> IO ()
writePopoverRelativeCell popover char = do
widget <- #getRelativeTo popover
cell <- unsafeCastTo Button widget
writeCell cell char
#hide popover
solveCell :: Cell -> IO ()
solveCell cell = do
char <- T.head <$> #getName cell
writeCell cell char
solveAll :: Cells -> IO ()
solveAll = mapM_ solveCell
solvePopoverRelativeCell :: Popover -> IO ()
solvePopoverRelativeCell popover = do
cell <- #getRelativeTo popover >>= unsafeCastTo Button
solveCell cell
#hide popover
cellsBindHandlers :: Cells -> Popover -> IO ()
cellsBindHandlers cells popover = mapM_ (\c -> do
on c #focusInEvent $ focusInHandler c
) cells
where focusInHandler c _ = do cellShowPopover c popover; pure False
checkCell :: Cell -> IO Bool
checkCell cell = do
solution <- T.head <$> (toWidget cell >>= #getName)
actual <- T.head <$> #getLabel cell
let isCorrect = actual == solution
style <- #getStyleContext cell
if not isCorrect
then #addClass style "incorrect"
else pure ()
forkIO $ threadDelay 800000 >> #removeClass style "incorrect"
pure isCorrect
checkAll :: Cells -> IO ()
checkAll cells = do
allAreCorrect <- and <$> mapM checkCell cells
if allAreCorrect
then mapM_ (\cell -> do
style <- #getStyleContext cell
#addClass style "correct"
forkIO $ threadDelay 800000 >> #removeClass style "correct"
) cells
else pure ()
cellShowPopover :: Cell -> Popover -> IO ()
cellShowPopover cell popover = do
popover `set` [#relativeTo := cell]
#show popover
numbersBindHandlers :: [Button] -> Popover -> IO ()
numbersBindHandlers buttons popover = mapM_ (\b -> do
on b #clicked $ numberButtonInsert b popover
) buttons
numberButtonInsert :: Button -> Popover -> IO ()
numberButtonInsert button popover = do
label <- #getLabel button
writePopoverRelativeCell popover $ T.head label
writeSudoku :: Cells -> Sudoku -> IO ()
writeSudoku cells sudoku = do
let sudokuChars = toString sudoku
sequence_ $ zipWith (\c sc -> do
writeCell c sc
if sc == blankval
then c `set` [#sensitive := True]
else c `set` [#sensitive := False]
) cells sudokuChars
writeSolution :: Cells -> Sudoku -> IO ()
writeSolution cells sudoku = do
let sudokuChars = toString sudoku
sequence_ $ zipWith (\c sc -> do
#setName c (T.singleton sc)
) cells sudokuChars
gameButtonsBindHandlers :: [Button] -> Cells -> Widget -> IO ()
gameButtonsBindHandlers buttons cells menu = do
mapM_ (\button -> do
label <- #getLabel button
let d = read . T.unpack $ label
on button #clicked $ newGame d cells menu
) buttons
newGame :: Difficulty -> Cells -> GameMenu -> IO ()
newGame d cells menu = do
Just sudoku <- loadSudoku d
let Just solution = head <$> solveSudoku sudoku
writeSudoku cells sudoku
writeSolution cells solution
#hide menu
showMenu :: GameMenu -> Popover -> IO ()
showMenu menu popover = do
#hide popover
popover `set` [#relativeTo := menu]
#show menu