Excercise Haskell

1a2b.hs

-- Excercise Haskell
-- Aim: 1A2B game without import library (random excluded)
-- Author: linnil1
import System.Random (randomRIO)
import qualified Data.Map as M


------------
-- utilities
------------
type Guess = [Int]
type Result = (Int, Int)
avail_character = [0..8]

removeItem :: Int -> [a] -> [a]
removeItem index arr = (take index arr) ++ (drop (index + 1) arr)

argMax :: Ord b => (a -> b) -> [a] -> a
argMax func (x:[]) = x
argMax func (x:xs)
    | (func x) < (func y) = y
    | otherwise = x
    where y = argMax func xs
argMax1 func x = snd $ maximum $ zip (map func x) x

colSum :: [Int] -> [Int] -> [Int]
colSum x y = map (\(a,b) -> a + b) (zip x y)

log2 x = log x / log 2

sort :: Ord a => [a] -> [a]
sort [] = []
sort (x:xs) = sort x1 ++ [x] ++ sort x2
    where x1 = filter (>=x) xs
          x2 = filter (<x) xs

randomAnswer :: Int -> IO(Guess)
randomAnswer n = randomChoiceN n avail_character
randomChoiceN :: Int -> [Int] -> IO([Int])
randomChoiceN 0 _ = return []
randomChoiceN n xs = do
    i <- randomRIO (0, length xs - 1)
    j <- randomChoiceN (n - 1) (removeItem i xs)
    return $ [xs !! i] ++ j


-- My counter using onehot (Using counter is much quicker)
resultEncode :: Result -> [Int]
resultEncode (a, b) = [(if i == x then 1 else 0) | i <- [0..100]]  -- ont hot
    where x = a * (length avail_character) + b
resultCount :: [Result] -> [Int]
resultCount xs = foldl1 colSum $ map resultEncode xs

counter :: [Result] -> [Int]
counter xs = map snd $ M.toAscList $ M.fromListWith (+) $ zip xs (repeat 1)


------------
-- Main 1A2B
------------
compareAnswer :: Guess -> Guess -> Result
compareAnswer answer guess = (
    countA $ filter        splitAB  ag,
    countB $ filter (not . splitAB) ag)
    where ag = zip answer guess
          splitAB (x, y) = x == y
          countA xs = length xs
          countB arr = foldl (\prev x -> prev + (fromEnum $ x `elem` ys)) 0 xs
              where (xs, ys) = unzip arr


checkNoDup :: Guess -> Bool
checkNoDup [] = True
checkNoDup (x:xs) = (not (x `elem` xs)) && checkNoDup xs

checkLeng :: Int -> Guess -> Bool
checkLeng n xs = length xs == n

checkAvailChar :: Guess -> Bool
checkAvailChar xs = all (`elem` avail_character) xs

raiseIfInvalid n xs = case checkNoDup xs && checkLeng n xs && checkAvailChar xs of 
    True -> return ()
    False -> error "Error" 


------------
-- Main: auto guess basic
------------
listPossibleAnswer :: Int -> [Guess]
listPossibleAnswer n = permutation n avail_character
permutation :: Int -> [Int] -> [[Int]]
permutation 1 poss = map (:[]) poss
permutation n poss = foldl1 (++) $ map (permutationSelectAndRecur n poss)  [0..length poss - 1]
    where permutationSelectAndRecur n poss i = map ([poss !! i]++) $ permutation (n - 1) (removeItem i poss)

filterPossible :: [Guess] -> Guess -> Result -> [Guess]
filterPossible poss guess result = filter (\i -> result==(compareAnswer i guess)) poss

listAndFilterPossible :: Int -> [(Guess, Result)] -> [Guess]
listAndFilterPossible n list_guess_result = foldl (\p (g,r) -> filterPossible p g r) (listPossibleAnswer n) list_guess_result


------------
-- Main: auto guess by entropy
------------
calcFreq :: [Int] -> [Float]
calcFreq xs = map (/sum_xs) new_xs
    where new_xs = map fromIntegral xs
          sum_xs = sum new_xs

calcEntropy:: Float -> Float
calcEntropy p = -p * log2 p

calcGuessEntropy :: [Guess] -> Guess -> Float
calcGuessEntropy poss guess = sum $ map calcEntropy $ calcFreq arr
    -- where arr = filter (/= 0) $ resultCount $ map (compareAnswer guess) poss
    where arr = counter $ map (compareAnswer guess) poss

getHighestEntropy :: [Guess] -> Guess
getHighestEntropy poss = argMax1 (calcGuessEntropy poss) poss


------------
-- IO PART
------------
getUserGuess :: a -> IO(Guess)
getUserGuess _ = do
    line <- getLine
    return (map read $ map (:[]) line)


getAutoGuess :: Int -> [(Guess, Result)] -> IO(Guess)
getAutoGuess n guess_result_list = do
    let poss = listAndFilterPossible n guess_result_list
    print $ "Possible: " ++ (show $ length poss) ++ " Entropy: " ++ (show $ log2 $ fromIntegral $ length poss)
    answer <- if guess_result_list == []
        then
            randomAnswer n
        else do
            let entropy = zip (map (calcGuessEntropy poss) poss) poss
            -- print "Entropy Stats"
            -- print entropy
            -- print $ M.fromListWith (+) $ zip  (map fst entropy) (repeat 1)
            -- let max_5_entropy = take 5 $ sort entropy
            -- print max_5_entropy
            let max_entropy = maximum entropy
            print $ "Select " ++ (show max_entropy)
            return $ snd max_entropy
    print answer
    return answer


isUserGuess :: IO(Bool) = do
    print "Is guessed by user? (Y/N)"
    x <- getLine
    case x of
        "Y" -> return True
        "N" -> return False

isUserAnswer :: IO(Bool) = do
    print "Is answered by user? (Y/N)"
    x <- getLine
    case x of
        "Y" -> return True
        "N" -> return False


getNumOfSize :: IO(Int) = do
    print "Number of digits? (4)"
    x <- getLine
    return $ read x


getUserAnswer :: Guess -> IO(Result)
getUserAnswer _ = do
    line <- getLine
    let result :: [Int] = map read $ words line
    return (result !! 0, result !! 1)


-- wrap compareAnswer
compareAnswerIO answer guess = do
    let result = compareAnswer answer guess
    print $ (show $ fst result) ++ "A" ++ (show $ snd result) ++ "B"
    return result


------------
-- Main
------------
gamePlay n getGuess evalAnswer game_iter prev_result = do
    print $ "Iter" ++ show game_iter
    guess <- getGuess prev_result
    raiseIfInvalid n guess
    result <- evalAnswer guess
    if (fst result) == n
    then do
        return ()
    else do
        gamePlay n getGuess evalAnswer (game_iter + 1) (prev_result ++ [(guess, result)])


main = do
    n <- getNumOfSize
    is_user_guess <- isUserGuess
    is_user_answer <- isUserAnswer
    answer <- if is_user_answer
        then do
            return $ replicate n (-1)
        else do
            a <- randomAnswer n
            print $ "Answer: " ++ (show a)
            return a

    let evalAnswer = if is_user_answer
        then
            getUserAnswer
        else
            -- return $ compareAnswer answer
            compareAnswerIO answer

    let getGuess = if is_user_guess
        then
            getUserGuess
        else
            getAutoGuess n
    
    gamePlay n getGuess evalAnswer 0 []

README.md

Case 1

root@7994b8a9e3ab:/app# ghc 1a2b.hs
Loaded package environment from /root/.ghc/x86_64-linux-9.4.5/environments/default
[1 of 2] Compiling Main             ( 1a2b.hs, 1a2b.o ) [Source file changed]
[2 of 2] Linking 1a2b [Objects changed]

root@7994b8a9e3ab:/app# ./1a2b
"Number of digits? (4)"
4
"Is guessed by user? (Y/N)"
N
"Is answered by user? (Y/N)"
Y

"Iter0"
[2,0,8,7]
0 1
"Iter1"
"Possible: 1440 Entropy: 10.491853096329676"
"Select (2.8588645,[9,8,6,5])"
[9,8,6,5]
1 2
"Iter2"
"Possible: 83 Entropy: 6.375039431346925"
"Select (2.8721385,[5,8,4,9])"
[5,8,4,9]
0 3
"Iter3"
"Possible: 12 Entropy: 3.5849625007211565"
"Select (3.2516289,[9,5,3,8])"
[9,5,3,8]
0 2
"Iter4"
"Possible: 1 Entropy: 0.0"
"Select (0.0,[8,9,6,4])"
[8,9,6,4]
4 0

Case 2

root@7994b8a9e3ab:/app# ./1a2b
"Number of digits? (4)"
4
"Is guessed by user? (Y/N)"
N
"Is answered by user? (Y/N)"
N
"Iter0"
[2,7,5,3]
"1A1B"
"Iter1"
"Possible: 720 Entropy: 9.491853096329676"
"Select (2.9461462,[9,8,7,3])"
[9,8,7,3]
"0A2B"
"Iter2"
"Possible: 165 Entropy: 7.366322214245815"
"Select (3.3179908,[5,7,8,6])"
[5,7,8,6]
"1A1B"
"Iter3"
"Possible: 26 Entropy: 4.700439718141093"
"Select (3.459491,[4,7,2,8])"
[4,7,2,8]
"1A0B"
"Iter4"
"Possible: 6 Entropy: 2.584962500721156"
"Select (2.5849626,[6,7,3,1])"
[6,7,3,1]
"1A2B"
"Iter5"
"Possible: 1 Entropy: 0.0"
"Select (0.0,[3,7,6,0])"
[3,7,6,0]
"4A0B"

Case 3

root@7994b8a9e3ab:/app# ./1a2b
"Number of digits? (4)"
4
"Is guessed by user? (Y/N)"
Y
"Is answered by user? (Y/N)"
N

"Iter0"
6087
"0A1B"
"Iter1"
9854
"0A2B"
"Iter2"
5309
"0A2B"
"Iter3"
4920
"0A3B"
"Iter4"
0542
"1A1B"
"Iter5"
0491
"4A0B"