Merge branch 'leynier' into main

Author: leynier

app/Main.hs

@@ -1,30 +1,84 @@
 module Main where
 
-import System.Random
 
-import Structures
 import Algorithms
+import Console
+import Structures
+import System.IO
+import System.Random
+
+
+main = do
+        putStrLn "Welcome to Hidato!!! Type 'help' to see the list of available commands."
+        hFlush stdout
+        console
+
+
+console :: IO ()
+console = do
+        Console.start cmds
 
+cmds :: [Command]
+cmds = [commandGenerate, commandSolve]
 
-main = do 
-        let rand = randomIO :: IO Int
-        seed <- rand
+
+generateFunction :: [Char] -> [Char] -> [Char] -> [Char] -> FilePath -> [Char] -> IO ()
+generateFunction rs cs ra di path to = do
+        seed <- randomIO :: IO Int
         let gen = mkStdGen seed
         let seeds = randoms gen :: [Int]
 
-        print "Introduzca la cantidad de filas:"
-        rowsString <- getLine
-        let rows = read rowsString :: Int
-        print "Introduzca la cantidad de columnas:"
-        columnsString <- getLine
-        let columns = read columnsString :: Int
-        print "Introduzca el radio de obstaculos:"
-        ratioString <- getLine
-        let ratio = read ratioString :: Float
-        print "Introduzca la dificultad:"
-        dificultyString <- getLine
-        let dificulty = read dificultyString :: Dificulty
-        m <- generateGame rows columns ratio dificulty
-        print m
-        let sol = solve m seeds
-        print sol
+        let rows = read rs :: Int
+        let columns = read cs :: Int
+        let ratio = read ra :: Float
+        let difficulty = read di :: Difficulty
+        let tout = read to :: Int
+
+        (ok, m) <- generateGame rows columns ratio difficulty tout
+
+        if ok then do
+                writeFile path (show m)
+                print m
+        else do
+                putStrLn "The generator could not generate a hidato with the indicated arguments and the indicated time." 
+
+
+commandGenerate :: Command
+commandGenerate =
+        Command
+        {
+                cmdName = "generate",
+                cmdDescription = "Command to generate a hidato. The board is save to a file.\nDifficulty: [Easy, Normal, Hard]\nDefault timeout: 60000000 microseconds = 1 minute",
+                cmdArgs = ["ROWS", "COLUMNS", "RATIO", "DIFFICULTY", "FILEPATH", "TIMEOUT (OPTIONAL)"],
+                cmdIO = \args -> do
+                        case args of
+                                [rs, cs, ra, di, path] -> generateFunction rs cs ra di path "60000000"
+                                [rs, cs, ra, di, path, to] -> generateFunction rs cs ra di path to
+                                otherwise -> print "The number of arguments is not correct"
+                        return 0
+        }
+
+
+commandSolve :: Command
+commandSolve =
+        Command
+        {
+                cmdName = "solve",
+                cmdDescription = "Command to solve a hidato. The board is obtained from a file.",
+                cmdArgs = ["FILEPATH"],
+                cmdIO = \args -> do
+                        case args of
+                                [filePath] -> do
+                                        text <- readFile filePath
+                                        let table = read text :: Matrix
+                                        seed <- randomIO :: IO Int
+                                        let gen = mkStdGen seed
+                                        let seeds = randoms gen :: [Int]
+                                        let solves = solveAll table seeds
+                                        if null solves then do
+                                                print "Solve not found"
+                                        else do
+                                                print $ head solves
+                                otherwise -> print "The number of arguments is not correct"
+                        return 0
+        }

hidato.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 8990a2fc1a1f4fa5cf6bcf0dc27fc8585348d19663dd6d611e9d1f7fb613dc4c
+-- hash: be00057decf180595c875f0852db5de4a7bb552ba6b5d44ec64fabd77e70bd53
 
 name:           hidato
 version:        0.1.0.0
@@ -27,6 +27,7 @@ source-repository head
 library
   exposed-modules:
       Algorithms
+      Console
       Structures
   other-modules:
       Paths_hidato

src/Algorithms.hs

@@ -1,5 +1,5 @@
 module Algorithms
-( Dificulty(..)
+( Difficulty(..)
 , generate
 , solve
 , solveAll
@@ -8,22 +8,25 @@ module Algorithms
 , validateTemplate
 ) where
 
-import System.Random
-import Structures
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe
 import Data.Set (Set, lookupMin, lookupMax)
 import qualified Data.Set as Set
 import Debug.Trace
-import Data.Map (Map)
-import qualified Data.Map as Map
+import Structures
+import System.Random
 import System.Timeout
-import Data.Maybe
+
 
 genRCell :: Int -> Int -> Int -> IO Cell
 genRCell rn cn val = do
       r <- randomRIO (1, rn)
       c <- randomRIO (1, cn)
       return $ Cell r c val
 
+
 genRCellFromSet :: Set Cell -> IO [Cell]
 genRCellFromSet set = if Set.null set
       then do
@@ -36,6 +39,7 @@ genRCellFromSet set = if Set.null set
             sets <- genRCellFromSet newSet
             return $ e : sets
 
+
 generateRandom :: Int -> Int -> Float -> IO Matrix
 generateRandom rn cn ratio = do
       let obs_ratio = if ratio < 0 || ratio > 1 then 0.33 else ratio
@@ -52,13 +56,16 @@ generateRandom rn cn ratio = do
             result <- generateRandom rn cn ratio
             return result
 
-data Dificulty = Easy | Normal | Hard deriving (Ord, Eq, Show, Read)
 
-emptyRatio :: Dificulty -> Float
+data Difficulty = Easy | Normal | Hard deriving (Ord, Eq, Show, Read)
+
+
+emptyRatio :: Difficulty -> Float
 emptyRatio Easy = 50/100
 emptyRatio Normal = 60/100
 emptyRatio Hard = 70/100
 
+
 generateRandomGame :: Int -> Int -> Float -> IO Matrix
 generateRandomGame rn cn ratio = do
       maybeTemplate <- timeout 1000000 $ generateRandom rn cn ratio
@@ -77,6 +84,7 @@ generateRandomGame rn cn ratio = do
             else do
                   return $ head solutions
 
+
 removeCells :: Matrix -> [Cell] -> Int -> Int -> [Int] -> Matrix
 removeCells sol@(Matrix rn cn cs) cells ite n seeds =
       if    null cells || ite >= n then
@@ -94,11 +102,12 @@ removeCells sol@(Matrix rn cn cs) cells ite n seeds =
                   else
                         removeCells sol tailCells (ite + 1) n seeds
 
-generateGame :: Int -> Int -> Float -> Dificulty -> IO Matrix
-generateGame rn cn ratio dif = do
-      maybeMatrix <- timeout 60000000 $ generateRandomGame rn cn ratio
+
+generateGame :: Int -> Int -> Float -> Difficulty -> Int -> IO (Bool, Matrix)
+generateGame rn cn ratio dif to = do
+      maybeMatrix <- timeout to $ generateRandomGame rn cn ratio
       if isNothing maybeMatrix then do
-            return $ error "Game not found"
+            return (False, blankMatrix 1 1)
       else do
             let solution = maybe (blankMatrix rn cn) (\x -> x) maybeMatrix
             let setForRemove = Set.filter (\x -> let v = value x in v > 1 && v < rn * cn) (matrix solution) :: Set Cell
@@ -109,11 +118,13 @@ generateGame rn cn ratio dif = do
             let gen = mkStdGen seed
             let seeds = randoms gen :: [Int]
             let game = removeCells solution randomCells 0 cant_empty seeds
-            return game
+            return (True, game)
+
 
 generate :: Matrix
 generate = read "{. x x x x x x x x \n . 8 x x x x x x x \n . . 11 x x x x x x \n 29 . 10 . x x x x x \n 30 . . . . x x x x \n . 31  1 38  .  . x x x \n . 32 . . 39 41 . x x \n . . . 22 . . 42 . x \n . . . . . . . 44 45}" :: Matrix
 
+
 stepMatrix :: Int -> Matrix -> Cell -> Map Int Cell -> [Int] -> [(Matrix, Cell)]
 stepMatrix step m@(Matrix rs cs ma) prevCell map seeds = if Map.notMember step map
       then [
@@ -125,9 +136,11 @@ stepMatrix step m@(Matrix rs cs ma) prevCell map seeds = if Map.notMember step m
       else  let actCell = map Map.! step
             in [newMatrix | isAdjacent actCell prevCell || value actCell == 1, let newMatrix = (m, actCell)]
 
+
 buildMap :: Matrix -> Map Int Cell
 buildMap ma@(Matrix r c m) = Set.foldl (\acc cell -> Map.insert (value cell) cell acc) Map.empty m
 
+
 validateTemplate :: Matrix -> Bool
 validateTemplate (Matrix rn cn cells)
       | sum [ 1 | degree <- degrees, degree == 0 ] > 0 = False 
@@ -137,15 +150,18 @@ validateTemplate (Matrix rn cn cells)
                         let adjacents = [ adjR | adj <- getAdjacents cell rn cn 0 [1..],
                                           let Just adjR = Set.lookupGE adj cells, adjR /= cell, value adjR == 0]]
 
+
 solveRecursiveDFS :: Matrix -> Int -> Cell -> Int -> Map Int Cell -> [Int] -> [Matrix]
 solveRecursiveDFS actualMatrix step prevCell obs map seeds
       | step == obs + 1 = [actualMatrix]
       | otherwise = let toAdd = stepMatrix step actualMatrix prevCell map seeds
                     in concat [ solveRecursiveDFS matrix (step + 1) prevCell obs map (tail seeds) | (matrix, prevCell) <- toAdd ]
 
+
 solveAll :: Matrix -> [Int] -> [Matrix]
 solveAll m = solveRecursiveDFS m 1 (Cell 0 0 0) (rows m * columns m  - countObstacles m) (buildMap m)
 
+
 solve :: Matrix -> [Int] -> Matrix
 solve m seeds = let solves = solveAll m seeds
           in case solves of [] -> error "Solve not found"

src/Console.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE BlockArguments #-}
+
+module Console
+( start
+, commandHelp
+, consoleLoop
+, commandExit
+, Command (..),
+) where
+
+
+import Control.Monad (when)
+import Data.List (find)
+import Debug.Trace
+import System.IO
+
+
+start :: [Command] -> IO ()
+start cmds = do
+  let cmdList = cmds ++ [commandExit]
+  let cmdListWithHelp = commandHelp (createHelp : cmdList) : cmdList
+  consoleLoop cmdListWithHelp
+  where 
+    createHelp = commandHelp [] 
+
+
+consoleLoop :: [Command] -> IO ()
+consoleLoop cmds = do
+  putStr "> "
+  hFlush stdout
+  input <- getLine
+  let command = words input
+  when (null command) do
+    -- empty case, just enter
+    start cmds
+  let r = find (\a -> head command == cmdName a) cmds
+  case r of
+    Just c -> do
+      ret <- cmdIO c $ tail command
+      case ret of
+        0 -> consoleLoop cmds
+        1 -> return ()
+    Nothing -> do 
+      putStrLn $ "Command \"" ++ head command ++ "\" not found. Try \"help\" to find all avalidable commands."
+      consoleLoop cmds
+
+
+data Command = Command
+  { cmdName :: String,
+    cmdDescription :: String,
+    cmdArgs :: [String],
+    cmdIO :: [String] -> IO Int
+  }
+
+
+-- Help Commands
+commandHelp :: [Command] -> Command
+commandHelp cmds =
+  Command
+    { cmdName = "help",
+      cmdDescription = "The Help command will help you in all your needs",
+      cmdArgs = ["COMMAND"],
+      cmdIO = \args -> do
+        case args of
+          [] -> do
+            putStrLn "Avalidable Commands: "
+            putStr $ unlines $ map printCmd cmds
+            putStrLn ""
+          [command] -> do
+            let r = find (\a -> command == cmdName a) cmds
+            case r of
+              Just c ->
+                putStr $
+                  unlines
+                    [ cmdName c ++ " - " ++ cmdDescription c,
+                      "Usage: " ++ cmdName c ++ " " ++ printArgs (cmdArgs c),
+                      ""
+                    ]
+              Nothing -> putStrLn $ "Command \"" ++ command ++ "\" not found. Try \"help\" to find all avalidable commands."
+        return 0
+    }
+  where
+    printArgs args = foldl (\a b -> a ++ "[" ++ b ++ "] ") "" args
+    printCmd c = unwords ["\t", cmdName c, "\t\t", printArgs (cmdArgs c)]
+
+
+commandExit :: Command
+commandExit =
+  Command
+    { cmdName = "exit",
+      cmdDescription = "Exit the console",
+      cmdArgs = [],
+      cmdIO = \_ -> do
+        putStrLn "Are you sure? y/n"
+        answer <- getLine
+        return case answer of
+          "y" -> 1
+          "n" -> 0
+    }