Minesweeper in haskell – Code Review Stack Exchange

I have recently been learning Haskell, and wrote a minesweeper project as an exercise. Here is link to the project.

Basically the code is separated into two parts, the pure part (no monads) and impure part (deals with random and IO). Since I’m pretty new, I’m a little iffy about the whole setup. Any advice would be appreciated.

{-# LANGUAGE LambdaCase #-}
module Game where

import Data.List
import Data.Maybe
import Data.List.Split
import Control.Monad.Random
import Control.Monad.IO.Class
import Control.Monad.Reader

data Square = Square Bool SquareStatus | NumberedSquare Int
data SquareStatus = Untouched | LostMine | Flagged
data Pos = Pos Int Int deriving (Eq)
data Env = Env {
  getInitPos :: Pos,
  getWidth :: Int,
  getHeight :: Int,
  getNumMines :: Int
}

type Board = ((Square))
type Game a = ReaderT Env IO a

instance Show Square where
  show (Square _ Untouched) = "."
  show (Square _ LostMine) = "x"
  show (Square _ Flagged) = "f"
  show (NumberedSquare num) = if num > 0 then show num else " "

infixl 6 |+|
Pos a b |+| Pos c d = Pos (a+c) (b+d)

---------------
-- Game Control
---------------
play :: Int -> Int -> Int -> IO ()
play w h numMines = do
  initPos <- readInput
  board <- runReaderT createRandomBoard $ Env initPos w h numMines
  play' board initPos

play' :: Board -> Pos -> IO ()
play' board initPos = case expand board (initPos) of
    Just nextBoard -> do 
      printBoard nextBoard
      if checkWin nextBoard then 
        print "You won!"
      else do
        nextPos <- readInput
        play' nextBoard nextPos
    Nothing -> do
      print "You Lost :("
      printBoard $ markBoard board

readInput :: IO Pos
readInput = do
  pos <- do
    putStrLn "Make a move: (Format Int Int)"
    getLine
  let (initX, initY) = splitOn " " pos
  return $ Pos (read initX - 1) (read initY - 1)

--------------
--Impure Stuff
--------------
createRandomBoard :: Game Board
createRandomBoard = do
  width <- asks getWidth
  height <- asks getHeight
  randomLayout <- randMines
  let field = take height $ chunksOf width $ genField randomLayout $ width * height
  lift $ return field

randMines :: Game (Int)
randMines = do
  width <- asks getWidth
  height <- asks getHeight
  pos <- asks getInitPos
  n <- asks getNumMines
  randomSample n $ delete (posToIndex pos width height) (0..width*height-1)

randomSample :: Int -> (a) -> Game (a)
randomSample 0 list = pure ()
randomSample k list = do
  i <- getRandomR (0, length list - 1)
  let (a, xs) = splitAt i list
  l <- if not (null xs) then randomSample (k-1) (a ++ tail xs) else lift $ return ()
  pure $ if not (null xs) then head xs : l else l

----------------
--Pure Functions
----------------
genField :: (Int) -> Int -> (Square)
genField mines = genField' (sort mines) 0
  where
  genField' () index size = replicate (size - index) (Square False Untouched)
  genField' mines@(x:xs) index size
    | x == index = Square True Untouched : genField' xs (index+1) size
    | otherwise = Square False Untouched : genField' mines (index+1) size

getSquare :: Board -> Pos -> Maybe Square
getSquare b (Pos x y)
  | x >= length b || x < 0 = Nothing
  | y >= length (head b) || y < 0 = Nothing
  | otherwise = Just (b !! x !! y)

getNearMines :: Board -> Pos -> Int
getNearMines b pos =
  let 
    d = (-1, 0, 1)
    dirs = (|+|) <$> (Pos a b| a <- d, b <- d) <*> (pos)
  in
    foldl (acc p -> case getSquare b p of
                       Just (Square True _) -> acc + 1
                       _ -> acc) 0 dirs
  
getExpansions :: Board -> Pos -> (Pos)
getExpansions b pos =
  case getSquare b pos of
    Nothing -> ()
    Just (Square True _) -> ()
    Just _ -> expansions
  where
    isZero = getNearMines b pos == 0
    ds = if isZero then
            (Pos a b | a <- (-1, 0, 1), b <- (-1, 0, 1))
          else
            (Pos a b | (a,b) <- ((-1, 0), (0, -1), (1, 0), (0, 1), (0, 0)))
    dirs = (|+|) <$> ds <*> (pos)
    bounded_dirs = filter ((Pos x y) -> x >= 0 && y >= 0) dirs
    filtered_dirs = if isZero then 
                      bounded_dirs
                    else
                      filter (n -> n == pos || getNearMines b n == 0) bounded_dirs
    expansions = foldl (acc p -> case getSquare b p of
                        Just s@(Square False Untouched) -> p : acc
                        _ -> acc) () filtered_dirs

expand :: Board -> (Pos) -> Maybe Board
expand b p = do
  let expansions = concat $ mapMaybe (expand' b) p
  let newboard = foldr ((ri, row) r ->
                  foldr ((ci, s) c ->
                    if Pos ri ci `elem` expansions then
                      NumberedSquare (getNearMines b $ Pos ri ci) : c
                    else 
                      s : c
                  ) () (zip (0..) row) : r
                ) () (zip (0..) b)
  let removeCur = filter (`notElem` p) expansions
  if not $ lost b p then
    if null removeCur then 
      return newboard 
    else 
      expand newboard removeCur
  else
    Nothing
  where
    expand' :: Board -> Pos -> Maybe (Pos)
    expand' b' p' =
      case getSquare b' p' of
        Nothing -> Nothing
        Just (Square True _ ) -> Nothing
        _ -> Just (getExpansions b' p')

    lost :: Board -> (Pos) -> Bool
    lost _ () = False
    lost b' (x:xs) =
      case getSquare b' x of
        Just (Square True _) -> True
        _ -> lost b' xs

checkWin :: Board -> Bool
checkWin b = 
  all (==True) $ 
  fmap (all (==True) . 
    fmap (case
            Square False Untouched -> False
            _ -> True)) b

-----------
--Utilities
-----------
indexToPos :: Int -> Int -> Int -> Pos
indexToPos index w h = Pos (mod index w) (index `div` w)

posToIndex :: Pos -> Int -> Int -> Int
posToIndex (Pos x y) w h = y * w + x

printBoard :: Board -> IO ()
printBoard b = do
  let width = length $ head b
  putStrLn $ replicate (width * 2) '-'
  mapM_ (putStrLn . unwords . fmap show) b
  putStrLn $ replicate (length b * 2) '-'

markBoard :: Board -> Board
markBoard b =
  foldr ((ri, row) r ->
    foldr ((ci, s) c ->
      case s of
        Square False _ -> NumberedSquare (getNearMines b $ Pos ri ci) : c
        Square True _ -> Square True LostMine : c
        _ -> s : c
    ) () (zip (0..) row) : r
  ) () (zip (0..) b)

haskell – Build a fixed-length vector from a recursive factory function

I need a function of type forall (n :: Nat). RandomGen q => q -> Vec n q. Obviously this is possible to do (correctly, don’t just repeat) using split.

(Documentation links: Nat, RandomGen, Vec, repeat, split, induction1.)

I generalized this to not specifically be about RNGs by taking the splitting/unfolding function as an argument. I’m not wedded to this decision; I don’t think it makes much difference.

import Data.Type.Nat (SNatI, induction1)
import Data.Vec.Lazy (Vec(VNil, (:::)))
import qualified Data.Vec.Lazy as Vec

unfold :: SNatI n =>
          (a -> (a, a)) ->
          a ->
          Vec n a
unfold uf value = induction1 VNil (vs -> let v ::: vs' = vs `Vec.snoc` value
                                              (v', v'') = uf v
                                          in Vec.init $ v' ::: v'' ::: vs')

It works, but it’s pretty clunky looking. Also, consider an example like

> import Data.Nat (Nat(Z, S))
> unfold (n -> (n * 2, n*2)) 1 :: Vec (S(S(S(S(S Z))))) Int
↪ 32 ::: 32 ::: 16 ::: 8 ::: 4 ::: VNil

That’s not wrong, but I think it would be just as correct (and less weird looking) if it came out to
32 ::: 16 ::: 8 ::: 4 ::: 2 ::: VNil.

Anyone know what options I’m overlooking?

haskell – Suggestions on making this parsing/unparsing format more human-friendly

I am working on some application which involves regular expressions with counting. Also, these regular expressions are not necessarily over some fixed alphabet, but over some class of predicates over bit-vectors.

I would like to be able parse/unparse these objects. I have come up with something that works, but I am concerned that the way this stands, this requires too many parens, and usually humans would not want to use parens in the places where I strictly require it. Suggestions on how I can make this entire thing closer to human syntax is welcome.

Also, general comments on haskell programming styles are welcome as well.

Here is the file Types.hs where the types are defined and also the unparsing

module Regex.Types where

import Data.List (intercalate)

data Regex a = -- this is required elsewhere
    Empty
  | Epsilon
  | Char a
  | Union (Regex a)
  | Concat (Regex a)
  | Star (Regex a)
  deriving Show

data CntRegex a =
  CEmpty
  | CEpsilon
  | CChar a
  | CUnion (CntRegex a)
  | CConcat (CntRegex a)
  | CStar (CntRegex a)
  | CCount Int Int (CntRegex a)
  | CCountUnbounded Int (CntRegex a)

data BoolExp a =
  BTrue
  | BFalse
  | BSelect a
  | BNot (BoolExp a)
  | BAnd (BoolExp a)
  | BOr ((BoolExp a))

instance Show a => Show (BoolExp a) where
  show BTrue = "true"
  show BFalse = "false"
  show (BSelect a) = show a
  show (BNot a) = "! " ++ parenwrap (show a)
  show (BAnd as) = intercalate " & " ( (parenwrap . show) <$> as)
  show (BOr as) =  intercalate " | " ( (parenwrap . show) <$> as)

instance Show a => Show (CntRegex a) where
  show (CEmpty) = "empty"
  show (CEpsilon) = "epsilon"
  show (CChar a) = bracketwrap $ show a
  show (CUnion as) = intercalate " | " ( (parenwrap . show) <$> as)
  show (CConcat as) = intercalate " " ( (parenwrap . show) <$> as)
  show (CStar a) =  parenwrap (show a) ++ " *"
  show (CCount i j a) = parenwrap (show a) ++ "{ "  ++ show i ++ ", " ++ show j ++ " }"
  show (CCountUnbounded i a) = parenwrap (show a) ++ "{ "  ++ show i ++ ", }"

parenwrap p = "(" ++ p ++ ")"
bracketwrap p = "(" ++ p ++ ")"

This is the Parser.hs file:

module Regex.Parser where

import Text.Parsec
import Text.Parsec.String
import qualified Text.Parsec.Token as P
import Text.Parsec.Language (emptyDef)

import Regex.Types

lexer       = P.makeTokenParser emptyDef

parens      = P.parens lexer
braces      = P.braces lexer
brackets    = P.brackets lexer
symbol      = P.symbol lexer
natural     = P.natural lexer
whiteSpace  = P.whiteSpace lexer

pSelect :: Integral a => Parser (BoolExp a)
pSelect = BSelect <$> fromIntegral <$> natural

pAnd :: Parser (BoolExp a) -> Parser (BoolExp a)
pAnd prsr = BAnd <$> prsr `sepBy1` (symbol "&")

pOr :: Parser (BoolExp a) -> Parser (BoolExp a)
pOr prsr = BOr <$> prsr `sepBy1` (symbol "|")

pNot :: Parser (BoolExp a) -> Parser (BoolExp a)
pNot prsr = BNot <$> ((symbol "!") *> prsr)

parseBool :: Integral a => Parser (BoolExp a)
parseBool = try (parens $ pNot parseBool)
        <|> try (parens $ pOr parseBool)
        <|> try (parens $ pAnd parseBool)
        <|> try (parens parseBool)
        <|> try (symbol "true" *> pure BTrue)
        <|> try (symbol "false" *> pure BFalse)
        <|> pSelect

parseRegex :: Integral a => Parser (CntRegex (BoolExp a))
parseRegex = whiteSpace *> pRegex <* eof

pRegex :: Integral a => Parser (CntRegex (BoolExp a))
pRegex =    try (parens $ pStar pRegex)
        <|> try (parens $ pUnion pRegex)
        <|> try (parens $ pConcat pRegex)
        <|> try (parens $ pCount pRegex)
        <|> try (parens $ pSingleCount pRegex)
        <|> try (parens $ pCountUnbounded pRegex)
        <|> try (parens $ pRegex)
        <|> try (brackets $ CChar <$> parseBool)
        <|> try pEmpty
        <|> pEpsilon

pEmpty :: Parser (CntRegex a)
pEmpty = symbol "empty" *> pure CEmpty

pEpsilon :: Parser (CntRegex a)
pEpsilon = symbol "epsilon" *> pure CEpsilon

pUnion :: Parser (CntRegex a) -> Parser (CntRegex a)
pUnion subparser = CUnion <$> subparser `sepBy1` (symbol "|")

pConcat :: Parser (CntRegex a) -> Parser (CntRegex a)
pConcat subparser = CConcat <$> many1 subparser

pStar :: Parser (CntRegex a) -> Parser (CntRegex a)
pStar subparser = CStar <$> subparser <* symbol "*"

pSingleCount :: Parser (CntRegex a) -> Parser (CntRegex a)
pSingleCount subparser = do
    exp <- subparser
    int <- fromIntegral <$> braces natural
    pure $ CCount int int exp

pCount :: Parser (CntRegex a) -> Parser (CntRegex a)
pCount subparser = do
    exp <- subparser
    symbol "{"
    lo <- fromIntegral <$> natural
    symbol ","
    hi <- fromIntegral <$> natural
    symbol "}"
    pure $ CCount lo hi exp

pCountUnbounded :: Parser (CntRegex a) -> Parser (CntRegex a)
pCountUnbounded subparser = do
    exp <- subparser
    symbol "{"
    lo <- fromIntegral <$> natural
    symbol ","
    symbol "}"
    pure $ CCountUnbounded lo exp
```

beginner – Haskell – Convert an Image to Ascii Art

I’m currently learning haskell, and I wanted a simple project to get started. This project uses the JuicyPixels package to handle image reading. The logic of the image to ascii art algorithm is quite simple:

  • quantize the image in a number of bins equal to the number of ASCII character we want to use
  • map each pixel to its ASCII counterpart.

The code is the following:

#!/usr/bin/env runhaskell

import Codec.Picture
import Data.Dynamic
import Data.Vector.Storable as V
import Data.Word
import Prelude as P

replacementChars :: (Char)
replacementChars = "#@&%=|;:. "

imageToAscii :: String -> Image Pixel8 -> (String)
imageToAscii mapChar img = chunksOf (imageWidth img) . toList $ V.map replaceByChar (imageData qImg)
  where
    qImg = quantizeImage (fromIntegral numBin) img
    replaceByChar p = mapChar !! fromIntegral p
    numBin = 1 + 255 `div` P.length mapChar

chunksOf :: Int -> (a) -> ((a))
chunksOf _ () = ()
chunksOf n xs = as : chunksOf n bs where (as, bs) = P.splitAt n xs

quantizeImage :: Word8 -> Image Pixel8 -> Image Pixel8
quantizeImage numBin = pixelMap (quantize numBin)

quantize :: Word8 -> Word8 -> Word8
quantize numBin x = x `div` numBin

rgbaToGray :: Image PixelRGBA8 -> Image Pixel8
rgbaToGray = pixelMap pixelAvg

-- contrast preserving for human vision RGB -> Gray is the following 0.2989 * R + 0.5870 * G + 0.1140 * B
pixelAvg :: PixelRGBA8 -> Pixel8
pixelAvg (PixelRGBA8 r g b a) = round $ 0.2989 * fromIntegral r + 0.5870 * fromIntegral g + 0.1140 * fromIntegral b

main :: IO ()
main = do
  img <- readImage "hamburger.png"
  case img of
    Left str -> print str
    Right img -> putStr $ unlines (imageToAscii replacementChars $ rgbaToGray (convertRGBA8 img))

An example of result on the hamburger emoji taken from Joypixel:

Hamburger emoji from joypixel

################################################################
################################################################
###########################          ###########################
######################                    ######################
###################                          ###################
################          .....::.....          ################
##############        ..::;;;;;;;;;;;;;:..        ##############
#############      .::;;;;;;;;;;;;;;;;;;;;::.      #############
###########      .:;;;;;;;;;;;;;;;;;;;;;;;;;;:.      ###########
##########     .:;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;:.     ##########
#########     :;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;:     #########
########    .:;;;;;;;;::;;;;;;;;;;;;;;;;::;;;;;;;;:.    ########
#######    .:;;;;;;;;;..;;;;;;;;;;;;;;;;..;;;;;;;;;:.    #######
######    .:;;;;;;;;;;::;;;;;;;::;;;;;;;::;;;;;;;;;;:.    ######
######   .:;;;;;;;;;;;;;;;;;;;;..;;;;;;;;;;;;;;;;;;;;:.   ######
#####    :;;;;;;;;;;;;;;;;;;;;;::;;;;;;;;;;;;;;;;;;;;;:    #####
#####   .;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;.   #####
####    :;;;;;;;::;;;;;;;;;;;;;;;;;;;;;;;;;;;;::;;;;;;;:    ####
####   .;;;;;;;;.:;;;;;;;;;;;;;;;;;;;;;;;;;;;;:.;;;;;;;;.   ####
####   :;;;;;;;;::;;;;;;;;;;;;;;;;;;;;;;;;;;;;::;;;;;;;;:   ####
####   :;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;:   ####
####   :;;;;;;;;;;;;;;;;;:::;;;;;;;;:::;;;;;;;;;;;;;;;;;:   ####
###   .;;;;;;;;;;;;;;;;;;:.:;;;;;;;;:.:;;;;;;;;;;;;;;;;;;.   ###
###   :;;;;;;;;;;;;;;;;;;;:;;;;;;;;;;:;;;;;;;;;;;;;;;;;;;:   ###
###   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;:   ###
###   :;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;   ###
###   :;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;|:   ###
###   .|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;|:   ###
###   .;|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;||;   ###
###   .||;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;||;   ###
###   .|=|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;|||;   ###
###   .;===|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;|||||;   ###
###   .:=====|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;|||||||:   ###
###   ::|======||;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;|||||||||=:   ###
##   .;:;======|||||||;;;;;;;;;;;;;;;;;;;;|||||||||||||=|;.   ##
##   :|::|=====|||||||||||||||||||||||||||||||||||||||==:|:   ##
##   ;%:::=====|||||||||||||||||||||||||||||||||||||||=|:%;   ##
##   ;%|::;=======||||||||||||||||||||||||||||||||||||=:|%;   ##
##   ;%%;::;======||||||||||||||||||||||||||||||||||||:;%%;   ##
##   :%%%;::;=====|||||||||====;;||||||||||||||||||||:;%%%:   ##
##   .%%%%;:::|===|||||||====|;::|||||====|||||||||||;%%%%.   ##
###   |%%%%|::::;=||||||===|;::::;||||=======||||||||%%%%|   ###
###   .%%%%%=;:::::;;;;;;;::::::::;||;=========|;;||%%%%%.   ###
####   ;%%%%%%=;::::::::::::::::::::;:::;;;;;:::;=%%%%%%;   ####
####    =%%%%%%%%|:::::::::::::::::::::::::::;|%%%%%%%%=    ####
#####   ;=%%%%%%%%=;:::::::::::::::::::::;;|%%%%%%%%%%=;   #####
#####   :;=%%%%%%%%%;::::::::::::::::;|=%%%%%%%%%%%%%=;:   #####
#####   :;;|%%%%%%%%%;:::::::::::::;=%%%%%%%%%%%%%%%|;;:   #####
#####   .;;;;=%%%%%%%%;:::::::::::;%%%%%%%%%%%%%%%=;;;;.   #####
#####    :;;;;|=%%%%%%%;:::::::::;%%%%%%%%%%%%%%=|;;;;:    #####
######   .;;;;;;;=%%%%%%;:::::::;%%%%%%%%%%%%%=;;;;;;;.   ######
######    :;;;;;;;;|=%%%%;:::::;%%%%%%%%%%%=|;;;;;;;;:    ######
#######    :;;;;;;;;;;;||=;:::;%%%%%%%=||;;;;;;;;;;;:    #######
########    :;;;;;;;;;;;;;;:::;;;;;;;;;;;;;;;;;;;;;:    ########
########     .:;;;;;;;;;;;;;:;;;;;;;;;;;;;;;;;;;;:.     ########
#########     ..:;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;:..     #########
###########      .:;;;;;;;;;;;;;;;;;;;;;;;;;;:.      ###########
############       ..:::;;;;;;;;;;;;;;;;:::..       ############
##############          ......::::......          ##############
################                                ################
###################                          ###################
#########################              #########################
################################################################
################################################################

Any advice, criticism, or coding-style improvement suggestion is welcome. It’s my first time working in a pure functional programming language, so there is probably some things to improve. I find the applicator function ($) a bit confusing, for example. I also felt a bit hindered by the strictness of the type system, but I guess it’s one feature one comes to love when working on a bigger codebase.

Typed vs untyped lambda calculus in methods for haskell

Expanding a bit on the following questions and their answers:

Give Lambda Calculus Term for Haskell Function

Infinite lists in Lambda calculus….

I really like the answers to the two questions, but it got me thinking:
Is it possible to find a solution for these in typed lambda-calculus?
My question is not straight about how to do it, since I think that would be a nice exercise to try, however, I would like to know if there is such a solution and more likely why. We have three cases here:

  1. Infinite list – I guess here the answer would be no, because of the fixed-point combinator. However, I’m not really sure why? I guess the problem is the value that is mapped to itself by the function but would be nice to get a “real” clarification on that one.
  2. Foldr – I think here it should be fine, since there is no fix-point combinator, but it doesn’t seem like “strong enough” reasoning.
  3. Map – Here I think the same logic applies as for folder.

Parsing custom text file using haskell

I am working on writing code for find difference between two text files that should be ideally same.

the format of file is
docid_{num}t{num}t{num0},{f0} {num1},{f1} ..... {numN},{fN}n

eg:
docid_0t300t5,2 4,3 9,2n

to perform this operation efficiently I have sorted both files based on numerical value within docid_{num} (num value) . and then wish to use an approach similar to 2 pointers.

that is assume
N = docid_{n} (from file1)
M = docid_{m} (from file2)

here I intend to use N and M as indexes. (again mentioning both files are sorted)

if N > M : docid_{N} is not present in file2
else if N < M : docid_{M} is not present in file1
else : both file contain doc_id with same values.

now the haskell code that I have written doesn’t seems to be as great as similar golang code. golang code takes roughly 2 seconds while this take 35 seconds. Any tips to improve it are welcomed.

I understand both are not exactly same, but I have tried to make main algorithm same.

result of profiling code, compiled with -O2 optimization flag.

       diff7 +RTS -sstderr -p -RTS sa3_10000 sa3_1_10000

    total time  =       34.05 secs   (34052 ticks @ 1000 us, 1 processor)
    total alloc = 97,676,092,088 bytes  (excludes profiling overheads)

COST CENTRE            MODULE    SRC                %time %alloc

readAsInt              Main      diff7.hs:44:1-39    77.1   76.3
readBothTogether.wrds1 Main      diff7.hs:146:5-43    4.8    5.9
readBothTogether.wrds2 Main      diff7.hs:147:5-43    4.8    5.9
splitInner.res         Main      diff7.hs:37:5-45     4.4    6.4
compare'.freqs1        Main      diff7.hs:173:5-57    1.9    1.5
compare'.freqs2        Main      diff7.hs:177:5-57    1.8    1.5
makePairs              Main      diff7.hs:41:1-77     0.9    1.5

haskell code

{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE BangPatterns     #-}
{-# LANGUAGE Strict     #-}

import qualified    Data.IntMap.Strict as IM (IntMap, fromList, difference, keys, intersection, toList, lookup, findWithDefault, empty, size)
import System.Environment

import qualified Data.Text as L
import Data.Text.IO as LTIO
import Data.Int


splitter :: Char -> Bool
splitter ' ' = True
splitter 't' = True
splitter _ = False


splitInner :: (L.Text) -> ((Int, Int))
splitInner inp = res1
  where
    res = L.splitOn (L.singleton ',') <$> inp
    res1 = makePairs res

makePairs :: ((L.Text)) -> ((Int, Int))
makePairs = map (x -> (readAsInt . head $ x, readAsInt . (head . tail) $ x))

readAsInt :: L.Text -> Int
readAsInt x = read $! L.unpack x :: Int
 {-
    Comparing result of two files need to take care of:
    + docuemtns present in result of only 1 file
    + common documents (present in both file's result)
      - missing token in one of file's result.
      - common token, but frequency different
      - happy scenario, frequency match too.
 -}

data DiffStruct =
  MkDiffStruct
    { documentsPresentInBoth           :: Int
    , documentsPresentOnlyInFirst      :: Int
    , documentsPresentOnlyInSecond     :: Int
    , documentsTokenCountDifferent     :: Int
    , documentsTokenFrequencyDifferent :: Int64
    , documentsTokenFrequencySame      :: Int64
    }
  deriving (Show)


correctingFactor = 14 -- 14 is constant difference due to algo difference

readBothTogether :: L.Text -> L.Text -> DiffStruct
readBothTogether t1 t2 = MkDiffStruct a b c d e f
  where
    wrds1 = L.split splitter <$> L.lines t1
    wrds2 = L.split splitter <$> L.lines t2
    (a,b,c,d,e,f) = compare' wrds1 wrds2

add' :: (Int,Int, Int, Int, Int64, Int64) -> (Int, Int, Int, Int, Int64, Int64) -> (Int, Int, Int, Int, Int64, Int64)
add' (a1, a2, a3, a4, a5, a6) (b1, b2, b3, b4, b5, b6) = (a1+b1, a2+b2, a3+b3, a4+b4, a5+b5, a6+b6)
{-
   add' will contain
   - document present only in first
   - document present only in second
   * same document
     - token present only in first
     - token present only in second
     - token present in both but different frequency
     - token present in both and same frequency
-}

compare' :: ((L.Text)) -> ((L.Text)) -> (Int, Int, Int, Int, Int64, Int64)
compare' _ ()  = (0,0,0,0,0,0)
compare' () _ = (0,0,0,0,0,0)
compare' inp1@(x:xs) inp2@(y:ys)
  | head1 > head2 = add' (1,0,0,0,0,0) $ compare' xs inp2
  | head1 < head2 = add' (0,1,0,0,0,0) $ compare' inp1 ys
  | otherwise = add' (0, 0, tokensPresentOnlyInFirst, tokensPresentOnlyInSecond, sameVal, diffVal) $ compare' xs ys
  where
    head1 = head x
    seconds1 = readAsInt . head . tail $ x
    freqs1 = IM.fromList . splitInner . drop 2 . init $ x

    head2 = head y
    seconds2 = readAsInt . head . tail $ y
    freqs2 = IM.fromList . splitInner . drop 2 . init $ y

    tokensPresentOnlyInFirst = IM.size $ IM.difference freqs1 freqs2
    tokensPresentOnlyInSecond = IM.size $ IM.difference freqs2 freqs1
    commonKeys = IM.intersection freqs1 freqs2
    (sameVal, diffVal) = compareCommonKeysInTwoMaps (IM.keys commonKeys) freqs1 freqs2

compareCommonKeysInTwoMaps :: (Int) -> IM.IntMap Int -> IM.IntMap Int -> (Int64, Int64)
compareCommonKeysInTwoMaps () _ _ = (0, 0)
compareCommonKeysInTwoMaps (x:xs) m1 m2
  | val1 == val2 = add2 (1, 0) $ compareCommonKeysInTwoMaps xs m1 m2
  | otherwise = add2 (0, 1) $ compareCommonKeysInTwoMaps xs m1 m2
  where
    val1 = IM.findWithDefault (-1) x m1
    val2 = IM.findWithDefault (-1) x m2

add2 :: (Int64, Int64) -> (Int64, Int64) -> (Int64, Int64)
add2 (a1, a2) (b1, b2) = (a1+b1, a2+b2)

main :: IO ()
main = do
  args <- getArgs
  let fp1 = head args
      fp2 = args !! 1
  print fp1
  print fp2
  inp1 <- LTIO.readFile fp1
  inp2 <- LTIO.readFile fp2

  print $ readBothTogether inp1 inp2

Adding golang code I’m comparing with

package main

import (
    "bufio"
    "fmt"
    "io"
    "log"
    "os"
    "strconv"
    "strings"
)

func main() {
    f1n := os.Args(1)
    f2n := os.Args(2)

    fmt.Println("first file: ", f1n)
    fmt.Println("second file: ", f2n)

    f1, err := os.Open(f1n)
    if err != nil {
        log.Fatalf("failed to open file1")
    }

    f2, err := os.Open(f2n)
    if err != nil {
        log.Fatalf("failed to open file2")
    }
    defer f1.Close()
    defer f2.Close()

    var line1 string
    var line2 string

    scanner1 := bufio.NewReader(f1)
    scanner2 := bufio.NewReader(f2)
    

    docPresentOnlyInFirst := 0
    docPresentOnlyInSecond := 0
    tokenPresentOnlyInFirst := 0
    tokenPresentOnlyInSecond := 0
    tokenPresentInBothSameFreq := 0
    tokenPresentInBothDiffFreq := 0
    i, j, ind := 0, 0, 0
    inc1, inc2 := true, true
    for {
        if inc1 {
            line1, err = scanner1.ReadString('n')
            if line1 == "" || (err != nil && err != io.EOF) {
                break
            }
            // As the line contains newline "n" character at the end, we could remove it.
            line1 = line1(:len(line1)-1)
        }

        if inc2 {
            line2, err = scanner2.ReadString('n')
            if line2 == "" || (err != nil && err != io.EOF) {
                break
            }
            // As the line contains newline "n" character at the end, we could remove it.
            line2 = line2(:len(line2)-1)
        }

        Doc1, f1 := lineParser(line1)
        Doc2, f2 := lineParser(line2)

        if Doc1 > Doc2 {
            docPresentOnlyInFirst++
            j++
            inc1 = false
        } else if Doc1 < Doc2 {
            docPresentOnlyInSecond++
            i++
            inc2 = false
        } else {
            a, b, c, d := compareFreq(f1, f2)
            tokenPresentOnlyInFirst += a
            tokenPresentOnlyInSecond += b
            tokenPresentInBothSameFreq += c
            tokenPresentInBothDiffFreq += d
            i++
            j++
            inc1, inc2 = true, true
        }
        if ind%50000 == 0 {
            fmt.Println("currently processing ", i, Doc1, j, Doc2, ind)
        }
        ind++
    }
    fmt.Println("total documents processed ", i, j, ind)

    fmt.Println("docPresentOnlyInFirst: ", docPresentOnlyInFirst)
    fmt.Println("docPresentOnlyInSecond: ", docPresentOnlyInSecond)
    fmt.Println("tokenPresentOnlyInFirst: ", tokenPresentOnlyInFirst)
    fmt.Println("tokenPresentOnlyInSecond: ", tokenPresentOnlyInSecond)
    fmt.Println("tokenPresentInBothSameFreq: ", tokenPresentInBothSameFreq)
    fmt.Println("tokenPresentInBothDiffFreq: ", tokenPresentInBothDiffFreq)
}

func compareFreq(f1, f2 map(int)int) (int, int, int, int) {
    a, c, d := onlyFirst(f1, f2)
    b, _, _ := onlyFirst(f2, f1)
    return a, b, c, d
}

func onlyFirst(f1, f2 map(int)int) (int, int, int) {
    a, d, c := 0, 0, 0
    for k1, v1 := range f1 {
        if v2, ok := f2(k1); !ok {
            a++
        } else {
            if v1 == v2 {
                c++
            } else {
                d++
            }
        }
    }
    return a, c, d
}

func SplitOnNonLetters(s string) ()string {
    return strings.Fields(s)
}

func lineParser(line string) (int, map(int)int) {
    parts := SplitOnNonLetters(line)
    if len(parts) <= 0 {
        tmp := make(map(int)int)
        return 0, tmp
    }
    docId, err := strconv.Atoi(parts(0)(6:))
    if err != nil {
        log.Fatalf("failed to parse dociId %v", docId)
    }
    // unigramCnt, _ := strconv.Atoi(parts(1))
    val := parts(2:)
    count := parseCommaSep(val)
    return docId, count
}

func parseCommaSep(inp ()string) map(int)int {
    tmp := make(map(int)int)

    for _, pair := range inp {
        keyVal := strings.Split(pair, ",")
        key, err := strconv.Atoi(keyVal(0))
        if err != nil {
            log.Fatalf("failed to parse key %v", key)
        }
        val, err := strconv.Atoi(keyVal(1))
        if err != nil {
            log.Fatalf("failed to parse value %v", val)
        }
        tmp(key) = val
    }

    return tmp
}

```

haskell – How to get the division of 2 elements as Floats on insert them on a list which can be printed later?

I hope you all are doing fine.

My past question has been solved but now I’m facing a new problem which has
given me lots of issues since I’m new to this and haven’t found the correct
examples to guide myself with.
Any help you can give me is highly appreciated.
The objective of this code is to obtain in the output, the average of
every array inputted like this:

3
1 2 3 0
4 5 6 0
7 8 0

Where 0 is a value that is not taken into account when calculating the average,
it only exists as a marking end.
An example of output considering the above is:

2 5 8

Also, consider that the output is rounded to the closest integer.

As for now I’ve made this code, but as I was saying before, I am new to this and
have been struggling a lot. Can you please help me to complete this?

creList :: Int -> (Int)
creList n = n:()

sumList :: (Int) -> Int
sumList ()    = 0
sumList (u:v) = u + sumList v

funavg :: Int -> IO ()
funavg numitint = if numitint == 0 then return () else do
    arrs <- getLine
    let
      arrnum = (map read(words arrs) :: (Int))
      total = sumList arrnum
      avg = div total ((length arrnum)-1)
      lavg = creList avg
    putStrLn (show lavg)
    funavg (numitint - 1)

main :: Prelude.IO ()
main = do
  numits <- getLine
  let
    numitint = read numits :: Int
  funavg numitint

In here I am using recursion based on the number of inputs,
but creating the output list and using the float function has been impossible for me.
If you wonder, I’m using curry (lang) which is mainly based on haskell, and because of this
I am not able to use libraries like Control.Monad.

Thank you very much!

haskell – State monad and pattern matching on data constructors

I am writing a Settlers of Catan server in Haskell for fun. Currently I am passing around state manually. I want to learn more about the State monad and want to incorporate it into my project.

However, my GameState has multiple data constructors that I pattern match on to yield different functionality. Three of such data constructors are for the WaitingLobby (when people can still join over the internet), the SetupPhase (before the game has really started and people have to build their initial settlements), and one for the RunningGame (when you can play the game turn by turn normally). Code:

data GameState = WaitingLobby ... | SetupPhase ... | RunningGame ...

Lots of functions pattern match on the type of data constructor used. For example the function that handles building a settlement after it has been decided that the player is indeed allowed to do so:

doConstructBuilding :: GameState -> Building -> VertexCoordinate -> GameState 
doConstructBuilding gs@(SetupPhase _ _ board _ _ _) building coord          = gs { board = placeBuilding building coord board,
                                                                                   _placedSettlement = True }
doConstructBuilding gs@(RunningGame playerList cur board _) building coord  = gs { board = placeBuilding building coord board, 
                                                                                   playerList = map payIfCur playerList}
                                    where payIfCur p | cur == playerId p = playerPays p $ constructionCost building
                                                     | otherwise         = p

So the different GameState dataconstructors have different implementations: In the SetupPhase the building is placed and it is noted that the player has placed a settlement in the state, while in the RunningGame the building is also placed, but here the player also pays resources for it.

The question: My understanding is that with the state monad you only pull out the state once you’re in the monadic context on the right side of the =. So How would I implement something like this?

Note: Maybe there are other solutions for this particular method, but I have a lot of these data constructor pattern match cases.

Fuzzy Finding in Haskell – Code Review Stack Exchange

In learning haskell, I’m writing a fuzzy menu. At the moment, my executable reads in a ‘dictionary’ from stdin, and ranks each word according to how well it fuzzily matches a search pattern given in the first CLI arg. The idea of the fuzzy matching algorithm is to split a pattern by its delimiters, and then match each character with a prefix of a token, accumulating a score to represent the quality of the match.

My main module looks like this:

module Main where

import           Data.List
import           Fuzzy
import           System.Environment

main :: IO ()
main = do
  contents <- getContents
  let dict = lines contents

  args <- getArgs
  let pattern = splitWord (head args)

  let scored  = map (x -> (score (x, pattern), x)) dict
  print (sort scored)

I’m not sure whether or not I’m misusing the do block and/or some I/O primitives here: overall, I think it could be better but I don’t know how to change it.

The Util module looks like this:

module Util
  ( splitWord
  , boolToFloat
  , nextChar
  ) where

splitWord :: String -> (String)
splitWord (l : '_' : r ) = splitWord ((l, '-') ++ r)
splitWord (l : '.' : r ) = splitWord ((l, '-') ++ r)
splitWord (l : ':' : r ) = splitWord ((l, '-') ++ r)
splitWord (l : '-' : r ) = ((l)) ++ splitWord r

splitWord (c       : ()) = ((c))
splitWord ()             = ()

splitWord s              = do
  let rest  = splitWord (tail s)
  let first = (head s) : (head rest)
  return first ++ tail rest

boolToFloat :: Bool -> Float
boolToFloat True  = 1.0
boolToFloat False = 0.0

nextChar :: (String) -> (String)
nextChar s = case tail (head s) of
  () -> tail s
  n  -> (n) ++ tail s

Especially in splitWord, I think the code here is somewhat repetitive, and again I don’t really know how to make it simpler.

And finally, the Fuzzy module is as follows:

module Fuzzy
  ( score
  ) where

import           Util

score :: (String, (String)) -> Float
score ((), _ ) = 0
score (_ , ()) = 0

score (s , t ) = boolToFloat (head s == head (head t))
  + max (score (tail s, t) * 0.8) (score (tail s, nextChar t))

This module (and function) is the one I have the least concerns about – most of the problems in my code (as I perceive them) are about IO and redundancy in splitWord’s pattern matching. Thanks for any advice!

haskell – Count number of days within each date range in a list of date ranges

Happily picked up Haskell a couple days back and working on the following use case.

Given a list of JSON objects with date fields and a start date, I want to create a list of weeks (here a tuple of dates, but improvements are welcome) from the start date to today plus a week, and count the number of days from the JSON that fall within each week.

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

import Data.Aeson
import GHC.Generics
import Network.HTTP.Conduit (simpleHttp)
import Data.Text (Text, intercalate)
import Data.Time
import Data.Time.Clock.POSIX
import Data.Map (Map, fromList, toList, insert, lookup)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Internal as BSI

parseDate str = utctDay $ parseTimeOrError True defaultTimeLocale "%d/%m/%Y" str :: Day

type DateRange = (Day, Day)
type DateRangeCount = (DateRange, Int)

_makeRanges :: Day -> Day -> (DateRange) -> (DateRange)
_makeRanges currDate endDate ranges
  | currDate <= endDate =
      let endRangeDate = addDays 6 currDate
          newCurrDate = addDays 1 endRangeDate
      in (currDate, endRangeDate) : _makeRanges newCurrDate endDate ranges 
  | otherwise = ranges

createRanges :: String -> UTCTime  -> (DateRange)
createRanges startDateString endTime =
  let startDate = parseDate startDateString
      endDate = utctDay endTime
  in _makeRanges startDate endDate ()

isDayInRange :: Day -> DateRange -> Bool
isDayInRange day range = day >= fst range && day <= snd range

findRange :: Day -> ((DateRange) -> (DateRange))
findRange day = filter $ isDayInRange day

incrementCount :: (DateRange) -> Map DateRange Int -> Person -> Map DateRange Int
incrementCount ranges countMap person =
  let range = head $ findRange (date person) ranges
  in case Data.Map.lookup range countMap of
      Just i -> insert range (i+1) countMap
      Nothing -> countMap

countPersons :: (Person) -> (DateRange) -> Map DateRange Int
countPersons persons ranges =
  let countMap = fromList $ map (, 0) ranges
  in foldl (incrementCount ranges) countMap persons

newtype Person =
  Person {date :: Day} deriving (Show, Generic)

instance FromJSON Person where
 parseJSON (Object o) = do
    dateString <- o .: "date"
    return Person {date = parseDate dateString}

getData :: Maybe String -> IO (Either String (Person))
getData url = case url of
  Just url -> eitherDecode <$> simpleHttp url
  Nothing -> return (eitherDecode <$> BSL.pack $ map BSI.c2w "({"date":"21/05/2021"},{"date":"01/06/2021"})")

main :: IO ()
main = do
    -- r <- getData $ Just "gg" 
    r <- getData Nothing
    case r of
        Left err -> putStrLn err
        Right persons -> do
          endTime <- getCurrentTime
          let ranges = createRanges "01/05/2021" endTime
              counts = countPersons persons ranges
          mapM_ print $ toList counts
          print $ sum counts

Current input “01/05/2021”, the output is:

((2021-05-01,2021-05-07),0)
((2021-05-08,2021-05-14),0)
((2021-05-15,2021-05-21),1)
((2021-05-22,2021-05-28),0)
((2021-05-29,2021-06-04),1)
((2021-06-05,2021-06-11),0)
2

Bonus question if it’s allowed:
I also want to type Map DateRange Int as DateRangeCountMap, but this messes with fromList’s expected type which is the raw Map. Any ideas?