Creating custom keyboard controls [Elm] - keyboard

I'm trying to create custom keyboard controls for a 4 player game. Right now, the keys are predetermined like this:
type Orient = { x:Int, y:Int }
type GameInput = { space:Bool, delta:Time, so1:Orient, so2:Orient, so3:Orient,
so4:Orient, amount:Int }
gameInput : Signal GameInput
gameInput =
let sampledInput = sampleOn delta
<| GameInput <~ Keyboard.space
~ delta
~ Keyboard.arrows
~ Keyboard.wasd
~ Keyboard.directions (toCode 'O')
(toCode 'L')
(toCode 'K')
(toCode 'M')
~ Keyboard.directions (toCode 'Y')
(toCode 'H')
(toCode 'G')
(toCode 'J')
~ amountPlayers.signal
in lift (Debug.watch "input") sampledInput
I have created (for each player) input of the form:
type CustomKeys = { up:Char, down:Char, left:Char, right:Char }
customKeys2 : Signal CustomKeys
customKeys2 = CustomKeys <~ ck2up.signal
~ ck2down.signal
~ ck2left.signal
~ ck2right.signal
ck2up : Input Char
ck2up = input 'W'
ck2down : Input Char
ck2down = input 'S'
ck2left : Input Char
ck2left = input 'A'
ck2right : Input Char
ck2right = input 'D'
A handler elsewhere will adjust the values of the input as needed by the player. But I'm having a hard time figuring out how to insert these values into the arguments for Keyboard.directions.
I have tried lifting the arguments into Keyboard.directions directly:
~ Keyboard.directions <~ ...
Any result will become a Signal of a Signal, which cannot be lifted onto GameInput (correctly).
I have tried passing on the chars as arguments into gameInput:
gameInput2 : Signal GameInput
gameInput2 = gameInput <~ customKeys2
gameInput : CustomKeys -> Signal GameInput
gameInput { up,down,left,right } = GameInput <~ Keyboard.directions (toCode up)
(toCode down)
(toCode left)
(toCode right)
Now gameInput2 will have as result a signal of a signal.
My last idea is to combine signals, but that doesn't seem like an option to me since I want one signal to depend on another signal.

Directly using Keyboard.directions is not gonna work. The problem is that at the start of the game the keys can be changed so you have some Signal Char. And Keyboard.direction goes from "normal types" to "signal types". So you can't lift it.
But you also have access to the keys that are currently held down, Keyboard.keysDown. I looked up the implementation of Keyboard.directions and I think you can recreate it in Elm in a way that has it take Signal Int arguments.
Here's an Elm implementation of the normal Keyboard.directions:
directions : Int -> Int -> Int -> Int -> Signal { x : Int, y : Int }
directions up down left right =
(\kd ->
List.filter (\ky -> List.member ky [up,down,left,right]) kd |>
List.foldl (\ky st -> if | ky == up -> { st | y <- st.y + 1 }
| ky == down -> { st | y <- st.y - 1 }
| ky == left -> { st | x <- st.x - 1 }
| ky == right -> { st | x <- st.x + 1 }
) {x=0,y=0}
) <~ Keyboard.keysDown
and here's the implementation you'll want to use:
directions : Signal Int -> Signal Int -> Signal Int -> Signal Int -> Signal { x : Int, y : Int }
directions up down left right =
(\u d l r kd ->
List.filter (\ky -> List.member ky [u,d,l,r]) kd |>
List.foldl (\ky st -> if | ky == u -> { st | y <- st.y + 1 }
| ky == d -> { st | y <- st.y - 1 }
| ky == l -> { st | x <- st.x - 1 }
| ky == r -> { st | x <- st.x + 1 }
) {x=0,y=0}
) <~ up ~ down ~ left ~ right ~ Keyboard.keysDown
Feel free to refactor, I just hacked this code together quickly so it's kind of too large for a single function.

Related

Haskell make recursion for Chars in String

I want to create game Magic 15 Puzzle in Haskell I have function set :: [[Char]] -> Char -> [[Char]] .
It switches Char with empty space in [[Char]].
*Main> pp puzzle2
AC DE
FBHIJ
KGLNO
PQMRS
UVWXT
*Main> pp (set puzzle2 'C')
A CDE
FBHIJ
KGLNO
PQMRS
UVWXT
*Main>
Now I want to do recursion for [Char] (or String) like this (To do set xs for previous set x)
puzzle :: Result -> [Char] -> Result
puzzle gameboard (x:xs) = set (set (x:xs) x) xs
But compilation says it is error:
Couldn't match expected type ‘Char’ with actual type ‘[Char]’
I expect this output:
*Main> pp(puzzle puzzle2 "CB")
ABCDE
F HIJ
KGLNO
PQMRS
UVWXT
What can I do to solve this? Thanks a lot in advance for answer!
Whole Code:
import Data.Char
type Result = [String]
pp :: Result -> IO ()
pp x = putStr (concat (map (++"\n") x))
puzzle2 :: [[Char]]
puzzle2 = ["AC DE",
"FBHIJ",
"KGLNO",
"PQMRS",
"UVWXT"]
getCords board x = head ( head [[(row_index, column_index) |(column_index, char) <- zip[1..] row, x == char] |(row_index,row)<- zip [1..]board,x `elem` row])
getRow board c = fst ( getCords board c)
getCol board c = snd ( getCords board c)
check ch1 ch2 board = (getRow board ch2 == getRow board ch1 + 1 || getRow board ch2 == getRow board ch1 - 1) && (getCol board ch1 == getCol board ch2) || ((getRow board ch1 == getRow board ch2) && (getCol board ch2 == getCol board ch1 + 1 || getCol board ch2 == getCol board ch1 - 1) )
set gameboard x | check x ' ' gameboard = [[if ch == ' ' then x else if ch == x then ' ' else ch | ch<- line] | line<-gameboard]
| not (check x ' ' gameboard ) = [[ch | ch<- line] | line<-gameboard]
puzzle :: Result -> [Char] -> Result
puzzle gameboard (x:xs) = set (set (x:xs) x) xs
Just change the last function to
puzzle :: Result -> [Char] -> Result
puzzle g [] = g
puzzle g (x:xs) = puzzle (set g x) xs

Haskell How to find an infinite loop?

I am a complete beginner at haskell and as such, I have a hard time debugging since it's so different from imperative languages. When I try to run this code, I get an infinite list of Int and I have no idea of why it's infinite. Now I know the code is probably very ugly and in no way efficient, but my goal is just to make it work, not make it work efficiently.
chaineVersSon :: String -> Int -> [Int]
chaineVersSon chaineAInterpreter battementParMinute = integriser (concat
(musicaliser (freqNotes (interpreter 9 4 1 5 chaineAInterpreter []))
battementParMinute))
integriser :: [Double] -> [Int]
integriser [] = []
integriser (note:notes) = (floor (note * 32767)):integriser notes
musicaliser :: [(Double, (Double, Double))] -> Int -> [[Double]]
musicaliser [] _ = []
musicaliser (note:notes) tempo = (creerSon note tempo 0):musicaliser notes tempo
creerSon :: (Double, (Double, Double)) -> Int -> Double -> [Double]
creerSon note tempo temps
| temps < (calcDuree note tempo temps) = (echantillonner note
temps):creerSon note tempo (temps + (1/(fromIntegral frequenceEchantillonage)))
| temps == (calcDuree note tempo temps) = (echantillonner note temps):[]
calcDuree :: (Double, (Double, Double)) -> Int -> Double -> Double
calcDuree note tempo temps = (60 * (fst(snd note)) / (fromIntegral tempo)) /
(1/(fromIntegral frequenceEchantillonage)) + temps
echantillonner :: (Double, (Double, Double)) -> Double -> Double
echantillonner note temps = ((snd (snd note)) / 10) * sin(2 * pi * (fst note) * temps)
--Fonction qui traite toutes les modifications d'état
interpreter :: Int -> Int -> Double -> Double -> String -> [((Int, Int),
(Double, Double))] -> [((Int, Int), (Double, Double))]
interpreter _ _ _ _ [] _ = []
interpreter note octave duree volume (etat:chaine) pile
| etat == '0' = interpreter note octave duree 0 chaine pile
| etat == '.' = interpreter note octave (duree*1.5) volume chaine pile
| etat == '/' = interpreter note octave (duree/2) volume chaine pile
| etat == '[' = interpreter note octave duree volume chaine (((note, octave), (duree, volume)):pile)
| etat == ']' = interpreter (fst (fst save)) (snd (fst save)) (fst (snd save)) (snd (snd save)) chaine pile
| etat >= 'a' && etat <= 'g' = interpreter (changerNote etat) octave duree volume chaine pile
| etat >= '2' && etat <= '9' = interpreter note (read [etat]) duree volume chaine pile
| etat == '&' = interpreter (fst (diminuer note octave)) (snd (diminuer note octave)) duree volume chaine pile
| etat == '&' = interpreter (fst (augmenter note octave)) (snd (augmenter note octave)) duree volume chaine pile
| etat == '!' = ((note, octave), (duree, volume)):(interpreter note octave duree volume chaine pile)
| otherwise = interpreter note octave duree volume chaine pile
where save = head pile
--Fonction pour changer la note selon l'option fournie
changerNote :: Char -> Int
changerNote etat
| etat == 'a' = 9
| etat == 'b' = 11
| etat == 'c' = 0
| etat == 'd' = 2
| etat == 'e' = 4
| etat == 'f' = 5
| etat == 'g' = 7
--Fonction qui diminue la note et l'octave si possible/nécéssaire
diminuer :: Int -> Int -> (Int, Int)
diminuer note octave
| note > 0 = (note - 1, octave)
| note == 0 && octave == 2 = (note, octave)
| otherwise = (11, octave - 1)
--Fonction qui augmente la note et l'octave si possible/nécéssaire
augmenter :: Int -> Int -> (Int, Int)
augmenter note octave
| note < 11 = (note + 1, octave)
| note == 11 && octave == 9 = (note, octave)
| otherwise = (0, octave + 1)
--Fonction récursive pour calculer la fréquence de chaque note à jouer
freqNotes :: [((Int, Int), (Double, Double))] -> [(Double, (Double, Double))]
freqNotes [] = []
freqNotes (note:notes) = ((calcFrequence (fromIntegral (fst (fst note))) (fromIntegral (snd (fst note)))), (fst (snd note), snd (snd note))):freqNotes notes
--Fonction qui calcule la fréquence selon la note et l'octave
calcFrequence :: Double -> Double -> Double
calcFrequence note octave = 440 * (2**(1/12))**((12 * octave) + note - 57)
main::IO()
main = do argv <- getArgs
chaine <- readFile ( argv !! 0 )
print "Begin..."
print ( chaineVersSon chaine ( ( read ( argv !! 1 ) ) :: Int ) )
print "Done!"
Normally in other languages I would just print things everywhere and see where the results get wrong but I don't know how to do that in Haskell without rewriting almost the entire code. What kind of method should I use to find where my code goes wrong?
I've read about trace, but I can't seem to be able to actually print anything with it.
If your list is infinite, that means creerSon always goes to the first case, which means temps is always smaller than calcDuree note tempo temps, which is because calcDuree has + temps at the end.
I noticed this by refactoring away at your code, making it shorter using library functions such as map, until I could read it.
You could have noticed this by running a code coverage tool such as stack test --coverage on your program to see what code ever gets reached.

Best Practices for Where clauses

I wrote a simple tic-tac-toe program in Haskell. It runs on the command line, has a one and two player mode, and implements a minimax algorithm when you play against it.
I'm used to writing proper code in OO languages, but Haskell is new to me. This code works reasonably well, but seems hard to read (even to me!). Any suggestions on how to make this code more...Haskellian?
import Data.List
import Data.Char
import Data.Maybe
import Control.Monad
data Square = A | B | C | D | E | F | G | H | I | X | O deriving (Read, Eq, Ord)
instance Show Square where
show A = "a"
show B = "b"
show C = "c"
show D = "d"
show E = "e"
show F = "f"
show G = "g"
show H = "h"
show I = "i"
show X = "X"
show O = "O"
type Row = [Square]
type Board = [Row]
data Player = PX | PO deriving (Read, Eq)
instance Show Player where
show PX = "Player X"
show PO = "Player O"
data Result = XWin | Tie | OWin deriving (Read, Show, Eq, Ord)
main :: IO ()
main = do
putStrLn "Let's play some tic tac toe!!!"
putStrLn "Yeeeaaaaaahh!!!"
gameSelect
gameSelect :: IO ()
gameSelect = do
putStrLn "Who gonna play, one playa or two??? (Enter 1 or 2)"
gameMode <- getLine
case gameMode of "1" -> onePlayerMode
"2" -> twoPlayerMode
gameMode -> gameSelect
where onePlayerMode = do
putStrLn "One playa"
putStrLn "Cool! Get ready to play...AGAINST MY INVINCIBLE TIC TAC TOE AI!!!!! HAHAHAHA!!!"
gameLoop 1 emptyBoard PX
twoPlayerMode = do
putStrLn "Two players"
gameLoop 2 emptyBoard PX
emptyBoard = [[A,B,C],[D,E,F],[G,H,I]]
gameLoop :: Int -> Board -> Player -> IO ()
gameLoop noOfPlayers board player = do
case detectWin board of Just XWin -> endgame board XWin
Just OWin -> endgame board OWin
Just Tie -> endgame board Tie
Nothing -> if noOfPlayers == 1
then if player == PX
then enterMove 1 board player
else enterBestMove board PO
else enterMove 2 board player
enterMove :: Int -> Board -> Player -> IO ()
enterMove noOfPlayers board player = do
displayBoard board
if noOfPlayers == 1
then do putStrLn ("Make your move. (A-I)")
else do putStrLn (show player ++ ", it's your turn. (A-I)")
move <- getLine
print move
if not $ move `elem` ["a","b","c","d","e","f","g","h","i"]
then do
putStrLn $ move ++ " is not a move, doofus"
gameLoop noOfPlayers board player
else if (read (map toUpper move) :: Square) `elem` [ sq | sq <- concat board]
then do
gameLoop noOfPlayers (newBoard (read (map toUpper move) :: Square) player board) (if player == PX then PO else PX)
else do
putStrLn "That square is already occupied"
gameLoop noOfPlayers board player
enterBestMove :: Board -> Player -> IO ()
enterBestMove board player = gameLoop 1 (newBoard bestmove player board) PX
where bestmove = fst $ findBestMove PO board
findBestMove :: Player -> Board -> (Square, Result)
findBestMove player board
| player == PO = findMax results
| player == PX = findMin results
where findMin = foldl1 (\ acc x -> if snd x < snd acc then x else acc)
findMax = foldl1 (\ acc x -> if snd x > snd acc then x else acc)
results = [ (sq, getResult b) | (sq, b) <- boards player board ]
getResult b = if detectWin b == Nothing
then snd (findBestMove (if player == PX then PO else PX) b)
else fromJust $ detectWin b
boards :: Player -> Board -> [(Square, Board)]
boards player board = [(sq, newBoard sq player board) | sq <- concat board, sq /= X, sq /=O]
displayBoard :: Board -> IO ()
displayBoard board = do
mapM_ print board
newBoard :: Square -> Player -> Board -> Board
newBoard move player board = [ [if sq == move then mark else sq | sq <- row] | row <- board]
where mark = if player == PX then X else O
detectWin :: Board -> (Maybe Result)
detectWin board
| [X,X,X] `elem` board ++ transpose board = Just XWin
| [X,X,X] `elem` [diagonal1 board, diagonal2 board] = Just XWin
| [O,O,O] `elem` board ++ transpose board = Just OWin
| [O,O,O] `elem` [diagonal1 board, diagonal2 board] = Just OWin
| [X,X,X,X,X,O,O,O,O] == (sort $ concat board) = Just Tie
| otherwise = Nothing
where
diagonal1 :: Board -> [Square]
diagonal1 bs = bs!!0!!0 : bs!!1!!1 : bs!!2!!2 : []
diagonal2 :: Board -> [Square]
diagonal2 bs = bs!!0!!2 : bs!!1!!1 : bs!!2!!0 : []
endgame :: Board -> Result -> IO ()
endgame board result = do
displayBoard board
if result `elem` [XWin, OWin]
then
let player = if result == XWin then PX else PO
in do
putStrLn ("The game is over, and " ++ show player ++ " wins!")
putStrLn ((if player == PX then show PO else show PX) ++ " is a loser lol")
else do
putStrLn "The game is a tie"
putStrLn "You are both losers! Ugh!"
putStrLn "Want to play again? (y/n)"
again <- getLine
if again `elem` ["y", "Y", "yes", "Yes", "YES"]
then gameSelect
else do
putStrLn "Goodbye"
EDIT: with special thanks to #Chi and #Caridorc, I've made the following changes. Further suggestions will be considered and updated as well
import Data.List
import Data.Char
import Data.Maybe
import Control.Monad
data Square = A | B | C | D | E | F | G | H | I | X | O deriving (Read, Eq, Ord)
instance Show Square where
show A = "a"
show B = "b"
show C = "c"
show D = "d"
show E = "e"
show F = "f"
show G = "g"
show H = "h"
show I = "i"
show X = "X"
show O = "O"
type Row = [Square]
type Board = [Row]
data Player = PX | PO deriving (Read, Eq)
instance Show Player where
show PX = "Player X"
show PO = "Player O"
data Result = XWin | Tie | OWin deriving (Read, Show, Eq, Ord)
main :: IO ()
main = do
putStrLn "Let's play some tic tac toe!!!"
putStrLn "Yeeeaaaaaahh!!!"
gameSelect
gameSelect :: IO ()
gameSelect = do
putStrLn "Who gonna play, one playa or two??? (Enter 1 or 2)"
gameMode <- getLine
case gameMode of
"1" -> onePlayerMode
"2" -> twoPlayerMode
_ -> gameSelect
where onePlayerMode = do
putStrLn "One playa"
putStrLn "Cool! Get ready to play...AGAINST MY INVINCIBLE TIC TAC TOE AI!!!!! HAHAHAHA!!!"
gameLoop 1 emptyBoard PX
twoPlayerMode = do
putStrLn "Two players"
gameLoop 2 emptyBoard PX
emptyBoard = [[A,B,C],[D,E,F],[G,H,I]]
displayBoard :: Board -> IO ()
displayBoard board = do
mapM_ print board
otherPlayer :: Player -> Player
otherPlayer PX = PO
otherPlayer PO = PX
gameLoop :: Int -> Board -> Player -> IO ()
gameLoop noOfPlayers board player = do
case detectWin board of
Just res -> endgame board res
Nothing -> case noOfPlayers of
1 -> case player of
PX -> enterMove 1 board player
PO -> enterBestMove board PO
2 -> enterMove 2 board player
enterMove :: Int -> Board -> Player -> IO ()
enterMove noOfPlayers board player = do
displayBoard board
case noOfPlayers of
1 -> do putStrLn ("Make your move. (A-I)")
2 -> do putStrLn (show player ++ ", it's your turn. (A-I)")
move <- getLine
print move
if not $ move `elem` ["a","b","c","d","e","f","g","h","i"] then do
putStrLn $ move ++ " is not a move, doofus"
gameLoop noOfPlayers board player
else if (read (map toUpper move) :: Square) `elem` (concat board) then do
gameLoop noOfPlayers (newBoard (read (map toUpper move) :: Square) player board) (otherPlayer player)
else do
putStrLn "That square is already occupied"
gameLoop noOfPlayers board player
enterBestMove :: Board -> Player -> IO ()
enterBestMove board player = gameLoop 1 (newBoard bestmove player board) PX
where bestmove = fst $ findBestMove PO board
findBestMove :: Player -> Board -> (Square, Result) -- minimax algorithm
findBestMove player board
| player == PO = findMax results
| player == PX = findMin results
where findMin = foldl1 (\ acc x -> if snd x < snd acc then x else acc)
findMax = foldl1 (\ acc x -> if snd x > snd acc then x else acc)
results = [ (sq, getResult b) | (sq, b) <- boards player board ]
getResult b = case detectWin b of
Nothing -> snd (findBestMove (otherPlayer player) b)
Just x -> x
boards :: Player -> Board -> [(Square, Board)]
boards player board = [(sq, newBoard sq player board) | sq <- concat board, sq /= X, sq /=O]
newBoard :: Square -> Player -> Board -> Board
newBoard move player board = [ [if sq == move then mark else sq | sq <- row] | row <- board]
where mark = if player == PX then X else O
detectWin :: Board -> (Maybe Result)
detectWin board
| [X,X,X] `elem` (triplets board) = Just XWin
| [O,O,O] `elem` (triplets board) = Just OWin
| [X,X,X,X,X,O,O,O,O] == (sort $ concat board) = Just Tie
| otherwise = Nothing
triplets :: Board -> [[Square]]
triplets board = board ++ transpose board ++ [diagonal1] ++ [diagonal2]
where
flat = concat board
diagonal1 = [flat !! 0, flat !! 4, flat !! 8]
diagonal2 = [flat !! 2, flat !! 4, flat !! 6]
endgame :: Board -> Result -> IO ()
endgame board result = do
displayBoard board
putStrLn $ endGameMessage result
putStrLn "Want to play again? (y/n)"
again <- getLine
if again `elem` ["y", "Y", "yes", "Yes", "YES"]
then gameSelect
else do
putStrLn "Goodbye"
endGameMessage :: Result -> String
endGameMessage result
| result `elem` [XWin, OWin] = winnerNotice ++ loserNotice
| otherwise = "The game is a tie\n" ++ "You are both losers! Ugh!"
where
winner = case result of
XWin -> PX
OWin -> PO
winnerNotice = "The game is over, and " ++ show winner ++ " wins!\n"
loserNotice = (show $ otherPlayer winner) ++ " is a loser lol"
Code style is often a matter of personal preference, in Haskell arguably more than in other languages with a "standard" style guide. Still, here's a few random suggestions.
Don't over-indent cases: just use another line
case gameMode of "1" -> onePlayerMode
"2" -> twoPlayerMode
gameMode -> gameSelect
vs
case gameMode of
"1" -> onePlayerMode
"2" -> twoPlayerMode
gameMode -> gameSelect
or even
case gameMode of
"1" -> onePlayerMode
"2" -> twoPlayerMode
_ -> gameSelect
case is usually preferred to if .. == Constructor:
if player == PX
then enterMove 1 board player
else enterBestMove board PO
vs
case player of
PX -> enterMove 1 board player
PY -> enterBestMove board PO
I'd strongly recommend against using partial functions like fromJust, since they can crash your program if you forget to check for Nothing beforehand. Safer alternatives exist, which never cause such crashes -- less burden on the programmer.
if detectWin b == Nothing
then snd (findBestMove (if player == PX then PO else PX) b)
else fromJust $ detectWin b
vs
case detectWin b of
Nothing -> snd $ findBestMove (if player == PX then PO else PX) b
Just x -> x
or
fromMaybe (snd $ findBestMove (if player == PX then PO else PX) b)
$ detectWin b
Try to factorize commonly used functions. For instance
nextPlayer PX = PO
nextPlayer PO = PX
can replace uses of
if player == PX then PO else PX
No do is needed when there's only one statement:
if noOfPlayers == 1
then do putStrLn ("Make your move. (A-I)") -- no need for parentheses here
else do putStrLn (show player ++ ", it's your turn. (A-I)")
Since you mention where in the title, let me state that I have mixed feelings about where, in general. I know I often tend to avoid where in favor of let, but this feeling is not shared with many other Haskellers, so take this with some care.
Personally, I tend to limit my where uses to one-liners:
foo = f x y
where x = ...
y = ...
Especially in do blocks, which might span several lines, I prefer lets:
foo = do
line
line using x -- what is x ??!?
line
...
line
where x = ... -- ah, here it is
vs
foo = do
line
let x = ...
line using x
line
...
line
However, feel free to adopt the style you find more readable.
Also don't forget to add a few comments, as #mawalker points out. Some definitions are obvious and don't need any explanation. Others could benefit from a few lines explaining the purpose.

Reactive Banana: Change status in data

Starting from the Counter example in Reactive Banana Wx that uses a normal Int to keep the counter status:
let networkDescription :: forall t. Frameworks t => Moment t ()
networkDescription = do
eup <- event0 bup command
edown <- event0 bdown command
let
counter :: Behavior t Int
counter = accumB 0 $ ((+1) <$ eup) `union` (subtract 1 <$ edown)
sink output [text :== show <$> counter]
network <- compile networkDescription
actuate network
how can I replace and update the Int counter with a more generic data like:
data Counter = Counter {
count :: Int
} deriving (Show)
let
counter :: Behavior t Counter
counter = accumB Counter { count = 0 } $ ??????
sink output [text :== show <$> count counter]
I don't know how to refer to the internal count function with something like this:
count = count mycounter + 1
Any idea?
The type of accumB is:
accumB :: a -> Event t (a -> a) -> Behavior t a
So if you want to define a Behavior t Counter with it you need to use events that carry Counter -> Counter functions:
-- For the sake of convenience...
overCount :: (Int -> Int) -> Counter -> Counter
overCount f c = c { count = f (count c) }
counter = accumB Counter { count = 0 } $
(overCount (+1) <$ eup) `union` (overCount (subtract 1) <$ edown)

Haskell custom data type and reprsentation

Say there is a stadium and the row number is something like A1-10, then B1-10 and so on until ZZ
How do I make a custom data type and use it to represent the seat in Haskell?
You can think of your enumeration as being composed of three parts
a first letter,
an (optional) second letter, and
a number between 1 and 10
The first and second part both rely upon the notion of "letter", so let's define that
data Letter
= La | Lb
| Lc | Ld
| Le | Lf
| Lg | Lh
| Li | Lj
| Lk | Ll
| Lm | Ln
| Lo | Lp
| Lq | Lr
| Ls | Lt
| Lu | Lv
| Lw | Lx
| Ly | Lz
deriving ( Eq, Ord, Show )
This type is explicitly enumerated instead of merely using Char so that we don't have to worry about the differences between lower and upper case or the problems of Char containing extra things like '-' and '^'. Since I enumerated the elements in alphabetical order, the autoderived instances like Ord behave properly.
We probably do want to take advantage of the fact that Letter is a subset of Char so let's write the projections, too.
-- This one always works since every letter is a character.
letterToChar :: Letter -> Char
letterToChar l = case l of
La -> 'a'
Lb -> 'b'
Lc -> 'c'
Ld -> 'd'
Le -> 'e'
Lf -> 'f'
Lg -> 'g'
Lh -> 'h'
Li -> 'i'
Lj -> 'j'
Lk -> 'k'
Ll -> 'l'
Lm -> 'm'
Ln -> 'n'
Lo -> 'o'
Lp -> 'p'
Lq -> 'q'
Lr -> 'r'
Ls -> 's'
Lt -> 't'
Lu -> 'u'
Lv -> 'v'
Lw -> 'w'
Lx -> 'x'
Ly -> 'y'
Lz -> 'z'
-- This one might fail since some characters aren't letters. We also do
-- automatic case compensation.
charToLetter :: Char -> Maybe Letter
charToLetter c = case Char.toLower of
'a' -> Just La
'b' -> Just Lb
'c' -> Just Lc
'd' -> Just Ld
'e' -> Just Le
'f' -> Just Lf
'g' -> Just Lg
'h' -> Just Lh
'i' -> Just Li
'j' -> Just Lj
'k' -> Just Lk
'l' -> Just Ll
'm' -> Just Lm
'n' -> Just Ln
'o' -> Just Lo
'p' -> Just Lp
'q' -> Just Lq
'r' -> Just Lr
's' -> Just Ls
't' -> Just Lt
'u' -> Just Lu
'v' -> Just Lv
'w' -> Just Lw
'x' -> Just Lx
'y' -> Just Ly
'z' -> Just Lz
_ -> Nothing -- default case, no match
Now we play the same game with "digits from 1 to 10"
data Digit
= D1 | D2
| D3 | D4
| ...
deriving ( Eq, Ord, Show )
digitToInt :: Digit -> Int
digitToInt = ...
intToDigit :: Int -> Maybe Digit
intToDigit = ...
We might even write other ways of retracting an Int to a Digit. For instance, we could (1) take the absolute value of the integer and then (2) take its div and mod against 10 seats. This will result in a Digit assignment and a row number.
intToDigitWrap :: Int -> (Int, Digit)
intToDigitWrap n = (row, dig) where
(row, dig0) = n `divMod` 10
-- we use an incomplete pattern match because we have an invariant
-- now that (dig0 + 1) is in [1, 10] so intToDigit always succeeds
Just dig = intToDigit (dig0 + 1)
And the final type is easy!
data Seat = Seat { letter1 :: Letter
, letter2 :: Maybe Letter
, digit :: Digit
} deriving ( Eq, Ord, Show )
The Ord type is again completely automatically correct as Nothing is less than Show x for any x and record ordering is lexicographic. We can also write a show instance that's a bit friendlier very simply
prettySeat :: Seat -> String
prettySeat s =
let l1 = [Char.toUpper $ letterToChar $ letter1 s]
l2 = case letter2 s of
Nothing -> ""
Just c -> [Char.toUpper $ letterToChar c]
dig = show (digitToInt (digit s))
in l1 ++ l2 ++ "-" ++ dig
In all likelihood the ability to inject the Letter and Digit types into their superset types Char and Int respectively will almost certainly come in handy when writing code later.

Resources