Building a training set of tags for haskell about haskell

[iHiD]

Exercise: collatz-conjecture

Code

module CollatzConjecture (collatz) where

collatz :: Integer -> Maybe Integer
collatz = collatz' 0
  where collatz' acc n
    | n < 1     = Nothing
    | n == 1    = Just acc
    | even n    = collatz' (acc + 1) (n `div`2)
    | otherwise = collatz' (acc + 1) (n * 3 + 1)

Tags:

construct:add
construct:backticked-expression
construct:binding
construct:divide
construct:equation
construct:function
construct:guards
construct:integer
construct:lambda
construct:method
construct:multiply
construct:number
construct:parameter
construct:pattern-matching
construct:recursion
construct:subtract
construct:underscore-number
construct:variable
construct:where-clause
paradigm:functional
technique:higher-order-functions
technique:looping

[iHiD]

Exercise: acronym

Code

module Acronym (abbreviate) where

import Data.Char (isAlpha, isUpper, toLower, toUpper)
import Data.Maybe (catMaybes)

abbreviate :: String -> String
abbreviate xs = head $ catMaybes [acronymDefined xs, generateAcronym xs]

-- If the first word is all caps and ends with a colon, it is the acronym for 
-- the remainder of the string.  Just output it (without the colon).
acronymDefined :: String -> Maybe String
acronymDefined xs = if xs /= [] && isAcronym word1
                    then Just $ init word1
                    else Nothing
  where
    word1 = head $ words xs

isAcronym :: String -> Bool
isAcronym xs = xs /= [] && last xs == ':' && all isUpper (init xs)

-- Otherwise generate the acronym.
-- 1. Remove any punctuation - replace with a space
-- 2. Make sure all words in the sentence start with a capital.
--    Any words that are all caps, make only the first letter cap.
-- 3. Filter out all non-cap characters.
generateAcronym :: String -> Maybe String
generateAcronym xs = Just as
  where
    ys = map (\c -> if isAlpha c then c else ' ') xs
    zs = unwords $ map capitalize $ words ys
    as = filter isUpper zs

capitalize :: String -> String
capitalize (x:xs) = toUpper x : if all isUpper xs then map toLower xs else xs

Tags:

construct:char
construct:comment
construct:if-then-else
construct:import
construct:invocation
construct:lambda
construct:list
construct:logical-and
construct:module
construct:parameter
construct:string
construct:variable
construct:visibility
paradigm:functional
paradigm:imperative
paradigm:logical
paradigm:object-oriented
technique:boolean-logic
technique:higher-order-functions

[iHiD]

Exercise: hamming

Code

module DNA ( hammingDistance ) where

hammingDistance :: String -> String -> Int
hammingDistance xs ys = sum $ map fromEnum $ zipWith (/=) xs ys

Tags:

construct:char
construct:dollar
construct:function
construct:invocation
construct:lambda
construct:list
construct:module
construct:parameter
construct:string
construct:variable
construct:visibility
paradigm:functional
paradigm:higher-order-functions

[iHiD]

Exercise: hamming

Code

module DNA (hammingDistance) where

hammingDistance :: String -> String -> Int
hammingDistance a b = length $ filter not $ zipWith (==) a b

Tags:

construct:application
construct:char
construct:curried-function
construct:definition
construct:filter
construct:function
construct:function-composition
construct:module
construct:parameter
construct:string
construct:variable
construct:visibility
paradigm:functional
technique:higher-order-functions

[iHiD]

Exercise: diamond

Code

module Diamond (diamond) where

import Data.Char (ord)

diamond :: Char -> Maybe [String]
diamond letter = 
  let padding = ord letter - ord 'A' 
  in Just $ render ['A'..letter] padding

render :: String -> Int -> [String]
render [] _ = []
render "A" padding = ["A"]
render ('A':list) padding = [aLine padding]
                          ++ render list (padding-1) 
                          ++ [aLine padding]
render [a] padding = [notALine a (padding-1)]
render (a:list) padding = [notALine a padding]
                        ++ render list (padding-1)
                        ++ [notALine a padding]


aLine padding = replicate padding ' '
              ++ "A"
              ++ replicate padding ' '

notALine letter padding = replicate padding ' '
                        ++ [letter]
                        ++ replicate (innerDistance letter) ' '
                        ++ [letter]
                        ++ replicate padding ' '


innerDistance letter = (((ord letter - ord 'A') - 1) * 2) + 1

Tags:

construct:add
construct:char
construct:import
construct:invocation
construct:lambda
construct:let
construct:list
construct:method
construct:multiply
construct:number
construct:parameter
construct:pattern-matching
construct:subtract
construct:variable
construct:visibility-modifiers
paradigm:functional
paradigm:imperative
paradigm:object-oriented
technique:higher-order-functions
uses:Ord

[iHiD]

Exercise: kindergarten-garden

Code

module Garden
    ( Plant (..)
    , defaultGarden
    , garden
    , lookupPlants
    ) where

import Debug.Trace

import Data.Char  ( toUpper )
import Data.List  ( sort )
import Data.Map   ( Map )
import Data.Maybe ( fromJust )

import qualified Data.Map as Map

data Plant
  = Clover
  | Grass
  | Radishes
  | Violets
  deriving (Eq, Show)

defaultGarden :: String -> Map String [Plant]
defaultGarden = garden defaultStudents

fromChar :: Char -> Maybe Plant
fromChar c =
  case toUpper c of
    'C' -> Just Clover
    'G' -> Just Grass
    'R' -> Just Radishes
    'V' -> Just Violets
    _   -> Nothing

garden :: [String] -> String -> Map String [Plant]
garden students plants = Map.fromList . map f . enumerate . sort $ students
  where f (n, s)  = (s, map (fromJust . fromChar . g) [0..3])
          where g 0 = plants !! ((offset n))
                g 1 = plants !! ((offset n) + 1)
                g 2 = plants !! ((offset n) + row)
                g 3 = plants !! ((offset n) + 1 + row)
                g _ = error "unexpected plant index"
                offset n = n * 2
                row      = 1 + ((length plants - 1) `div` 2)
        enumerate = zip [0..]

lookupPlants :: String -> Map String [Plant] -> [Plant]
lookupPlants = Map.findWithDefault []

defaultStudents =
  [ "Alice"
  , "Bob"
  , "Charlie"
  , "David"
  , "Eve"
  , "Fred"
  , "Ginny"
  , "Harriet"
  , "Ileana"
  , "Joseph"
  , "Kincaid"
  , "Larry"
  ]

Tags:

construct:add
construct:char
construct:case
construct:data-declaration
construct:double
construct:error
construct:equation
construct:explicit-conversion
construct:expression
construct:floating-point-number
construct:function
construct:guarded-equation
construct:import
construct:infix-operator
construct:int
construct:integral-number
construct:invocation
construct:lambda
construct:list
construct:local-binding
construct:map
construct:module
construct:multiply
construct:number
construct:parameter
construct:pattern-matching
construct:subtract
construct:underscore
construct:variable
construct:where
construct:word
paradigm:functional
paradigm:imperative
paradigm:object-oriented
technique:higher-order-functions
uses:Map

[iHiD]

Exercise: robot-simulator

Code

{-# LANGUAGE LambdaCase #-}
module Robot
    ( Bearing(East,North,South,West)
    , bearing
    , coordinates
    , mkRobot
    , simulate
    , turnLeft
    , turnRight
    ) where

import Data.Bifunctor ( first, second )

data Bearing
  = North
  | East
  | South
  | West
  deriving (Eq, Show)

type Coords = (Integer, Integer)

data Robot = Robot Bearing Coords

bearing :: Robot -> Bearing
bearing (Robot bearing _) = bearing

coordinates :: Robot -> Coords
coordinates (Robot _ coords) = coords

mkRobot :: Bearing -> Coords -> Robot
mkRobot = Robot

simulate :: Robot -> String -> Robot
simulate robot ""     = robot
simulate robot (x:xs) = simulate (step robot) xs
  where step =
          case x of
            'L' -> mapBearing turnLeft
            'R' -> mapBearing turnRight
            'A' -> advance
            _   -> error ("unexpected instruction: " ++ show x)

mapBearing :: (Bearing -> Bearing) -> Robot -> Robot
mapBearing f (Robot bearing coords) = Robot (f bearing) coords

mapCoords :: (Coords -> Coords) -> Robot -> Robot
mapCoords f (Robot bearing coords) = Robot bearing (f coords)

advance :: Robot -> Robot
advance (Robot bearing coords) = Robot bearing (f coords)
  where f = case bearing of
          North -> second (+1)
          East  -> first  (+1)
          South -> second (subtract 1)
          West  -> first  (subtract 1)

turnLeft :: Bearing -> Bearing
turnLeft North = West
turnLeft East  = North
turnLeft South = East
turnLeft West  = South

turnRight :: Bearing -> Bearing
turnRight North = East
turnRight East  = South
turnRight South = West
turnRight West  = North

Tags:

construct:big-integer
construct:char
construct:data-declaration
construct:empty-list
construct:equational-reasoning
construct:error
construct:export
construct:function
construct:import
construct:integer
construct:integral-number
construct:lambda
construct:list
construct:module
construct:name-collision
construct:pattern-matching
construct:record
construct:string
construct:type
construct:type-alias
construct:underscore
construct:variable
construct:where-clause
paradigm:functional
paradigm:imperative
paradigm:object-oriented
technique:higher-order-functions
uses:Show

[iHiD]

Exercise: robot-simulator

Code

module Robot
    ( Bearing(East,North,South,West)
    , bearing
    , coordinates
    , mkRobot
    , simulate
    , turnLeft
    , turnRight
    ) where

import Data.Complex

data Bearing = North
             | East
             | South
             | West
             deriving (Eq, Show)

data Robot = Robot {
        robotPosition :: Complex Double,
        robotBearing :: Complex Double
    }

bearing :: Robot -> Bearing
bearing = bearingFromComplex . robotBearing

coordinates :: Robot -> (Integer, Integer)
coordinates r = let (x :+ y) = robotPosition r
                in ((round x), (round y))

mkRobot :: Bearing -> (Integer, Integer) -> Robot
mkRobot b (x, y) = Robot ((fromIntegral x) :+ (fromIntegral y)) (bearingToComplex b)

simulate :: Robot -> String -> Robot
simulate = foldl step
    where step (Robot p b) 'L' = Robot p (turnLeft' b)
          step (Robot p b) 'R' = Robot p (turnRight' b)
          step (Robot p b) 'A' = Robot (p + b) b
          step r _ = r

turnLeft :: Bearing -> Bearing
turnLeft = bearingFromComplex . turnLeft' . bearingToComplex

turnRight :: Bearing -> Bearing
turnRight = bearingFromComplex . turnRight' . bearingToComplex

turnLeft' = (* (0 :+ 1))

turnRight' = (* (0 :+ (-1)))

bearingToComplex North = 0 :+ 1
bearingToComplex East = 1 :+ 0
bearingToComplex South = 0 :+ (-1)
bearingToComplex West = (-1) :+ 0

bearingFromComplex v | realPart v > 0 = East
                     | realPart v < 0 = West
                     | imagPart v > 0 = North
                     | otherwise = South

Tags:

construct:add
construct:char
construct:constructor
construct:data-declaration
construct:double
construct:equation
construct:expression
construct:field-label
construct:floating-point-number
construct:import
construct:invocation
construct:lambda
construct:let-binding
construct:named-argument
construct:number
construct:parameter
construct:pattern-matching
construct:record
construct:string
construct:subtract
construct:underscore
construct:variable
construct:visibility-modifiers
paradigm:functional
paradigm:object-oriented
technique:higher-order-functions

[iHiD]

Exercise: robot-simulator

Code

module Robot (Bearing(..), Robot, mkRobot, coordinates, simulate, bearing, turnRight, turnLeft) where

import Data.List (foldl')

type Coordinates = (Int, Int)
data Bearing = North | East | South | West deriving (Show, Eq, Enum)
data Robot = Robot Bearing Coordinates deriving (Show, Eq)

mkRobot :: Bearing -> Coordinates -> Robot
mkRobot = Robot

bearing :: Robot -> Bearing
bearing (Robot b _) = b

coordinates :: Robot -> Coordinates
coordinates (Robot _ xy) = xy

simulate :: Robot -> String -> Robot
simulate = foldl' run
  where
    run (Robot b xy@(x, y)) c = case c of
      'R' -> Robot (turnRight b) xy
      'L' -> Robot (turnLeft b) xy
      'A' -> Robot b $ case b of
        North -> (x, y + 1)
        East  -> (x + 1, y)
        South -> (x, y - 1)
        West  -> (x - 1, y)

turnRight :: Bearing -> Bearing
turnRight West = North
turnRight b = succ b

turnLeft :: Bearing -> Bearing
turnLeft North = West
turnLeft b = pred b

Tags:

construct:add
construct:at-pattern
construct:case
construct:char
construct:data-declaration
construct:deriving
construct:eq
construct:import
construct:integral-number
construct:invocation
construct:lambda
construct:number
construct:pattern
construct:record-constructor
construct:string
construct:subtract
construct:type-alias
construct:underscore
construct:variable
construct:visibility-modifiers
paradigm:functional
paradigm:object-oriented
technique:higher-order-functions

[iHiD]

Exercise: protein-translation

Code

module ProteinTranslation (proteins) where


import           Text.Parsec        (choice, many, manyTill, parse, try)
import           Text.Parsec.Char   (string)
import           Text.Parsec.String (Parser)

rightToMaybe :: Either a b -> Maybe b
rightToMaybe (Right b) = Just b
rightToMaybe (Left _)  = Nothing

proteins :: String -> Maybe [String]
proteins = rightToMaybe . parse parseProteins "(input)"

parseProteins :: Parser [String]
parseProteins = many protein

protein :: Parser String
protein  = choice
  [ try (string "AUG") *> return "Methionine"
  , try (string "UUU") *> return "Phenylalanine"
  , try (string "UUC") *> return "Phenylalanine"
  , try (string "UUG") *> return "Leucine"
  , try (string "UUA") *> return "Leucine"
  , try (string "UCU") *> return "Serine"
  , try (string "UCC") *> return "Serine"
  , try (string "UCA") *> return "Serine"
  , try (string "UCG") *> return "Serine"
  , try (string "UAU") *> return "Tyrosine"
  , try (string "UAC") *> return "Tyrosine"
  , try (string "UGC") *> return "Cysteine"
  , try (string "UGU") *> return "Cysteine"
  , try (string "UGG") *> return "Tryptophan"
  ]

Tags:

construct:.
construct:..
construct:*>
construct:import
construct:invocation
construct:lambda
construct:list
construct:module
construct:pattern-matching
construct:return
construct:string
construct:variable
paradigm:functional
paradigm:higher-order-functions
technique:using-functions
uses:ProteinTranslation
uses:Text.Parsec

[iHiD]

Exercise: series

Code

module Series (digits, slices) where

import Data.List

digits :: String -> [Int]
digits = map (read . (:[]))

slices :: Int -> [a] -> [[a]]
slices n = takeWhile ((== n) . length) . map (take n) . tails

Tags:

construct:composition
construct:function
construct:import
construct:lambda
construct:list
construct:module
construct:parameter
construct:pointfree
construct:string
construct:top-level-definition
construct:variable
construct:visibility-modifiers
paradigm:functional
technique:higher-order-functions

[iHiD]

Exercise: crypto-square

Code

module CryptoSquare (encode) where

import qualified Data.Char as C
import qualified Data.List as L

encode :: String -> String
encode s =
    let s' = map C.toLower $ filter C.isAlphaNum s
        (r, c) = dimensions $ length s'
    in unwords $ L.transpose $ slices c s'

dimensions sz =
    let c = ceiling $ sqrt $ fromIntegral sz
        r = (sz-1) `div` c + 1
    in (r, c)

slices _ [] = []
slices n xs =
    let (h, t) = L.splitAt n xs
    in h:(slices n t)

Tags:

construct:add
construct:backtick
construct:char
construct:divide
construct:double
construct:explicit-conversion
construct:expression
construct:filter
construct:floating-point-number
construct:import
construct:infix-function
construct:invocation
construct:lambda
construct:let
construct:list
construct:local-binding
construct:map
construct:module
construct:number
construct:parameter
construct:pattern-matching
construct:qualified-import
construct:string
construct:subtract
construct:tuple
construct:underscore
construct:variable
construct:visibility-modifiers
paradigm:functional
paradigm:higher-order-functions
technique:math
technique:recursion
technique:type-conversion
uses:Data.Char
uses:Data.List
uses:Tuple

[iHiD]

Exercise: custom-set

Code

{-# LANGUAGE NoImplicitPrelude #-}

module CustomSet (CustomSet, fromList, empty, delete, difference, isDisjointFrom, null, intersection, member, insert, size, isSubsetOf, toList, union) where

import CorePrelude hiding (Set)
import qualified Text.Show as Text (show)

import Data.List ((++))
import Data.Foldable (Foldable, foldr, toList, elem, sum, and)
import Data.Bool.HT ((?:))

type CustomSet = Set
data Set a = Empty | Leaf a | Node (Set a) a (Set a)

instance (Eq a) => Eq (Set a) where
  x == y = toList x == toList y

instance (Show a) => Show (Set a) where
  show s =  (++) "fromList " . Text.show $ toList s

instance Foldable Set where
  foldr _ acc Empty = acc
  foldr f acc (Leaf v) = f v acc
  foldr f acc (Node l v r) = foldr f (f v (foldr f acc r)) l

instance Functor Set where
  fmap _ Empty = Empty
  fmap f (Leaf n) = Leaf (f n)
  fmap f (Node l n r) = Node (fmap f l) (f n) (fmap f r)

size :: (Integral a) => Set a -> a
size = sum . fmap (\_ -> 1)

isSubsetOf :: (Eq a) => Set a -> Set a -> Bool
isSubsetOf s t = and $ fmap (flip elem t) s

union :: (Ord a) => Set a -> Set a -> Set a
union s = foldr (\x acc -> insert x acc) s

null :: Set a -> Bool
null s = case s of
  Empty -> True
  _ -> False

delete :: (Ord a) => a -> Set a -> Set a
delete v s = foldr (\x acc -> 
                      x /= v ?: (insert x acc, acc)
                   ) Empty s

isDisjointFrom :: (Ord a) => Set a -> Set a -> Bool
isDisjointFrom s t = s `difference` t == s

difference :: (Ord a) => Set a -> Set a -> Set a
difference s t = filter (not . flip elem t) s

intersection :: (Ord a) => Set a -> Set a -> Set a
intersection s t = filter (flip elem t) s

member :: (Eq a) => a -> Set a -> Bool
member = elem

fromList :: (Ord a) => [a] -> Set a
fromList s = case s of
  [] -> Empty
  (x:xs) -> foldr insert (singleton x) xs

empty :: Set a
empty = Empty

singleton :: a -> Set a
singleton = Leaf

filter :: (Ord a) => (a -> Bool) -> Set a -> Set a
filter f = foldr (\x acc -> 
                    f x ?: (insert x acc, acc) 
                 ) Empty

insert :: (Ord a) => a -> Set a -> Set a
insert v Empty = singleton v
insert v (Leaf n) = case compare v n of
  EQ -> Leaf n
  LT -> Node (Leaf v) n Empty
  GT -> Node Empty n (Leaf v)
insert v s@(Node l n r) = case compare v n of
  EQ -> s
  LT -> Node (insert v l) n r
  GT -> Node l n (insert v r)

Tags:

construct:application
construct:as-pattern
construct:backtick
construct:boolean
construct:case
construct:char
construct:comment
construct:curried-function
construct:data-type
construct:definition
construct:do-block
construct:equals
construct:explicit-conversion
construct:expression
construct:extension
construct:field
construct:filter
construct:foldr
construct:functor
construct:guard
construct:hide
construct:if-else
construct:import
construct:instance
construct:int
construct:integral-number
construct:invocation
construct:lambda
construct:list
construct:local-binding
construct:method
construct:module
construct:number
construct:parameter
construct:pattern
construct:qualifier
construct:set
construct:string
construct:subtract
construct:sum-type
construct:type
construct:type-alias
construct:underscore
construct:using-directive
construct:variable
construct:visibility-modifiers
paradigm:functional
paradigm:object-oriented
technique:higher-order-functions
technique:inheritance
technique:recursion
technique:type-conversion
uses:Data.Set
uses:Set

[iHiD]

Exercise: pig-latin

Code

module PigLatin (translate) where
import qualified Data.Set as Set
import qualified Data.List as List

vowels = Set.fromList ['a', 'e', 'i', 'o', 'u']
cluster = Set.fromList ['x', 'y']

translate :: String -> String
translate xs = unwords $ map translate' $ words xs
    where translate' vs =
                let (b, e) = breakByState step vs
                in e ++ b ++ "ay"
          step [] v
            | Set.member v vowels = Just ([], [])
            | otherwise = Nothing
          step xs@(x:_) v
            | Set.member v vowels = if x /= 'q' || v /= 'u' then Just (xs, []) else Nothing
            | otherwise = if Set.member x cluster then Just ([], xs) else Nothing

breakByState f xs =
    let (begin, end) = breakByState' [] xs
    in (reverse begin, end)
            where
                breakByState' prev [] = (prev, [])
                breakByState' prev xs@(x:xs') =
                    case f prev x of
                        Just (b, e) -> (b, (reverse e) ++ xs)
                        Nothing -> breakByState' (x:prev) xs'

Tags:

construct:assignment
construct:break
construct:case
construct:char
construct:constructor
construct:else
construct:if-then-else
construct:import
construct:infix-application
construct:invocation
construct:lambda
construct:let
construct:list
construct:logical-or
construct:module
construct:parameter
construct:pattern-matching
construct:qualified-name
construct:string
construct:top-level-definition
construct:underscore
construct:variable
construct:visibility-modifiers
paradigm:functional
paradigm:imperative
paradigm:object-oriented
technique:boolean-logic
technique:higher-order-functions
technique:laziness
technique:recursion
uses:Set

[iHiD]

Exercise: poker

Code

module Poker where

import           Control.Applicative             (liftA2, (<|>))
import           Control.Applicative.Alternative (asum)
import           Control.Monad                   (guard, void)
import           Control.Monad.Combinators       (count)
import           Data.Functor                    (($>))
import           Data.List                       (nub, sort, sortOn)
import           Data.Maybe                      (isJust)
import qualified Data.MultiSet                   as MS
import           Data.Ord                        (comparing)
import           Data.Tuple                      (swap)
import           Text.Megaparsec
import           Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer      as L

data Value = Two | Three | Four | Five | Six | Seven
           | Eight | Nine | Ten | Jack | Queen | King | Ace
           deriving (Eq, Ord, Enum, Show)

data Suit = Diamond | Clubs | Hearts | Spades deriving (Eq, Show)

data Hand = Hand { flush      :: Bool
                 , cardCounts :: [Int] -- descending order
                 , cardValues :: [Value] -- tie-breaker values
                 } deriving (Eq, Show)

straightHigh :: Hand -> Maybe Value
straightHigh hand = case sort (cardValues hand) of
  [Two, Three, Four, Five, Ace] -> Just Five
  vals | length vals /= 5 -> Nothing
       | isStraight vals -> Just $ maximum vals
       | otherwise -> Nothing
  where isStraight vals = and [ succ x == y
                              | (x, y) <- zip vals (tail vals) ]

fourOfAKindOrFH :: Hand -> Bool
fourOfAKindOrFH hand = case cardCounts hand of
  [4, 1] -> True
  [3, 2] -> True
  _      -> False

instance Ord Hand where
  compare = comparing g
    where g hand = ( flush hand && isJust (straightHigh hand)
                   , fourOfAKindOrFH hand
                   , flush hand
                   , straightHigh hand
                   , cardCounts hand
                   , cardValues hand
                   )

type Parser  = Parsec () String

lexeme :: Parser a -> Parser a
lexeme = L.lexeme space

parseValue :: Parser Value
parseValue = let helper (key, val) = string key $> val in
  asum . fmap helper $
  zip ["2", "3", "4", "5", "6", "7", "8", "9", "10", "J", "Q", "K", "A"]
      [Two .. Ace]

parseFace :: Parser Suit
parseFace = asum [ char 'D' $> Diamond
                 , char 'C' $> Clubs
                 , char 'H' $> Hearts
                 , char 'S' $> Spades
                 ]

parseCard :: Parser (Value, Suit)
parseCard = lexeme $ liftA2 (,) parseValue parseFace

isFlush :: [Suit] -> Bool
isFlush suits = length (nub suits) == 1

toCardCounts :: [Value] -> ([Int], [Value])
toCardCounts values = (fst <$> sortedOccs, snd <$> sortedOccs)
  where sortedOccs = reverse . sort . fmap swap .
                     MS.toOccurList . MS.fromList $ values

parseHand :: Parser Hand
parseHand = do
  cards <- space *> count 5 parseCard <* eof
  let suits = snd <$> cards
      (ccs, vals) = toCardCounts (fst <$> cards)
  return $ Hand (isFlush suits) ccs vals

toHand :: String -> Maybe Hand
toHand = parseMaybe parseHand

maximaBy :: Ord b => (a -> b) -> [a] -> [a]
maximaBy f = foldr compare []
  where compare x [] = [x]
        compare x (y : ys)
          | f x < f y = (y : ys)
          | f x > f y = [x]
          | f x == f y = (x : y : ys)

bestHands :: [String] -> Maybe [String]
bestHands hands
  | and (isJust . toHand <$> hands) = Just (maximaBy toHand hands)
  | otherwise = Nothing

Tags:

construct:and
construct:applicative
construct:as-pattern
construct:assignment
construct:boolean
construct:char
construct:combinator
construct:compare
construct:constructor
construct:data-declaration
construct:do-block
construct:enum
construct:equational-reasoning
construct:explicit-import
construct:extension
construct:field-label
construct:foldr
construct:guard
construct:import
construct:int
construct:integral-number
construct:invocation
construct:lambda
construct:lazy-evaluation
construct:length
construct:let
construct:list
construct:local-definitions
construct:logical-and
construct:method
construct:module
construct:number
construct:optional-parameter
construct:ordering
construct:parameter
construct:pattern-matching
construct:qualified-name
construct:return
construct:set
construct:string
construct:type
construct:type-alias
construct:underscore
construct:variable
construct:visibility-modifiers
paradigm:declarative
paradigm:functional
paradigm:logical
paradigm:metaprogramming
paradigm:reflective
technique:boolean-logic
technique:higher-order-functions
technique:laziness
technique:looping
uses:Data.List
uses:Data.MultiSet
uses:Text.Megaparsec
uses:Text.Megaparsec.Char

[iHiD]

Exercise: sgf-parsing

Code

{-# LANGUAGE OverloadedStrings #-}
module Sgf (parseSgf) where

import Data.Map  (Map, fromList)
import Data.Text (Text)
import Data.Tree (Tree, Tree(Node))
import Control.Applicative ((<|>))
import qualified Data.Text as Text

import qualified Text.Parsec as Parsec

parseSgf :: Text -> Maybe (Tree (Map Text [Text]))
parseSgf sgf = case Parsec.parse parseBracedNode "" sgf of
    Left _ -> Nothing
    Right tr -> Just tr

parseNodes = (Parsec.try parseBracedNodes) <|>
    (Parsec.try $ fmap (:[]) parseDepthNodes)

parseBracedNodes = do
    n <- parseBracedNode
    ns <- Parsec.option [] parseNodes
    return (n:ns)

parseBracedNode = do
    Parsec.char '('
    n <- parseDepthNodes
    Parsec.char ')'
    return n

parseDepthNode = do
    Parsec.char ';'
    parseProperties

parseDepthNodes = do
    ps <- parseDepthNode
    ns <- Parsec.option [] parseNodes
    return $ Node (fromList ps) ns

parseProperties = Parsec.many parseProperty

parseProperty = do
    p <- fmap Text.pack $ Parsec.many1 Parsec.upper
    vs <- Parsec.many1 parsePropertyValue
    return (p, vs)

parsePropertyValue = do
    Parsec.char '['
    v <- Parsec.many1 propertyChar
    Parsec.char ']'
    return $ Text.pack $ concat v

propertyChar =
    Parsec.choice [
        (fmap (:[]) Parsec.alphaNum),
        (do
            Parsec.char '\\'
            (fmap (:[]) $ Parsec.oneOf "]\\") <|>
                (Parsec.anyChar >>= (const $ return ""))
        ),
        (do
            Parsec.space
            return " "
        )]

Tags:

construct:char
construct:import
construct:invocation
construct:lambda
construct:list
construct:module
construct:parameter
construct:string
construct:underscore
construct:variable
paradigm:functional
paradigm:higher-order-functions
paradigm:monadic
technique:parsing
uses:Text

[iHiD]

Exercise: go-counting

Code

module Counting (
    Color(..),
    territories,
    territoryFor
) where

import qualified Data.Array as Array
import qualified Data.List as List
import qualified Data.Set as Set
import Data.Array ((!))

data Color = Black | White deriving (Eq, Ord, Show)
type Coord = (Int, Int)

data Elem = EmptyElem | BlackElem | WhiteElem deriving (Eq)

data ColorState = EmptyState | MixedState | BlackState | WhiteState
    deriving Eq

territories :: [String] -> [(Set.Set Coord, Maybe Color)]
territories board =
    let b = makeBoard board
    in fst $ foldl (step b) ([], Set.empty) $ Array.indices b
        where step b r@(rs, seen) p
                  | Set.member p seen = r
                  | otherwise = case territoryForBoard b p of
                      Just t -> (t:rs, Set.union (fst t) seen)
                      Nothing -> r

territoryFor :: [String] -> Coord -> Maybe (Set.Set Coord, Maybe Color)
territoryFor board coord =
    let b = makeBoard board
    in territoryForBoard b coord

territoryForBoard board coord
    | (not $ onBoard board coord) || (board ! coord /= EmptyElem) = Nothing
    | otherwise = fmap (\(cs, col) -> (cs, stateToColor col)) $
        fill board Set.empty EmptyState [coord]

makeBoard b =
    let cols = length b
        rows = if null b then 0 else length $ head b
    in Array.listArray ((1, 1), (rows, cols)) $ map valToColor $
        concat $ List.transpose b

fill _ seen color [] = Just (seen, color)
fill board seen color (c:cs) =
    let curColor = board ! c
    in case curColor of
        EmptyElem ->
            let cs' = filter (\p -> (onBoard board p) &&
                    (not $ Set.member p seen))
                        (move c)
            in fill board (Set.insert c seen) color (cs' ++ cs)
        _ -> fill board seen (mergeStates color (elemToState curColor)) cs

move (r, c) = [(r + (1 - i `div` 2)*((i `mod` 2)*2-1), c +
                (i `div` 2)*((i `mod` 2)*2-1)) |
                    i <- [0..3]]

onBoard board (r, c) =
    let ((br, bc), (er, ec)) = Array.bounds board
    in r >= br && r <= er &&
        c >= bc && c <= ec

mergeStates EmptyState color = color
mergeStates color EmptyState = color
mergeStates MixedState color = MixedState
mergeStates color MixedState = MixedState
mergeStates leftColor rightColor
    | leftColor == rightColor = leftColor
    | otherwise = MixedState

valToColor 'W' = WhiteElem
valToColor 'B' = BlackElem
valToColor _ = EmptyElem

elemToState EmptyElem = EmptyState
elemToState WhiteElem = WhiteState
elemToState BlackElem = BlackState

stateToColor EmptyState = Nothing
stateToColor MixedState = Nothing
stateToColor WhiteState = Just White
stateToColor BlackState = Just Black

Tags:

construct:add
construct:boolean
construct:case
construct:char
construct:constructor
construct:data-type
construct:deriving
construct:divide
construct:do-block
construct:enum
construct:equation
construct:explicit-conversion
construct:expression
construct:filter
construct:floating-point-number
construct:function
construct:guarded-equation
construct:if-then-else
construct:import
construct:infix-operator
construct:int
construct:integral-number
construct:invocation
construct:lambda
construct:let
construct:list
construct:local-binding
construct:logical-and
construct:logical-or
construct:method
construct:multiply
construct:number
construct:parameter
construct:pattern-matching
construct:qualifier
construct:set
construct:string
construct:subtract
construct:tuple
construct:type
construct:type-constructor
construct:underscore
construct:variable
construct:visibility-modifiers
paradigm:functional
paradigm:imperative
paradigm:object-oriented
technique:boolean-logic
technique:higher-order-functions
uses:Set.Set

[iHiD]

Exercise: zipper

Code

module Zipper
 ( BinTree(BT)
 , fromTree
 , left
 , right
 , setLeft
 , setRight
 , setValue
 , toTree
 , up
 , value
 ) where

import qualified Data.Map as M
import Data.Maybe (isNothing, fromJust)
 
data BinTree a = BT { btValue :: a
                    , btLeft  :: Maybe (BinTree a)
                    , btRight :: Maybe (BinTree a)
                    } deriving (Eq, Show)

data Zipper a = Zipper { _index :: Int
                       , _ups :: [Int]
                       , _map :: M.Map Int a
                       } deriving (Eq, Show)

child :: Int -> Zipper a -> Maybe (Zipper a)
child c (Zipper i us m) = 
    let li = i * 2 + c
    in if li `M.member` m
       then Just $ Zipper li (i:us) m
       else Nothing

fromTree :: BinTree a -> Zipper a
fromTree = Zipper 0 [] . treeToMap M.empty 0

left = child 1

purge :: M.Map Int a -> Int -> M.Map Int a
purge m i = let i2 = i * 2 
            in if i `M.notMember` m
               then m
               else flip purge (i2 + 2) . flip purge (i2 + 1) $ M.delete i m

right = child 2
           
setChild :: Int -> Maybe (BinTree a) -> Zipper a -> Zipper a
setChild c tree (Zipper i us m) = 
    let childIndex = i * 2 + c
    in case tree of
        Nothing -> Zipper i us $ purge m childIndex
        _       -> Zipper i us . treeToMap m childIndex $ fromJust tree
        
setLeft = setChild 1

setRight = setChild 2    

setValue :: a -> Zipper a -> Zipper a
setValue v (Zipper i us m) = Zipper i us $ M.insert i v m

toTree :: Zipper a -> BinTree a
toTree (Zipper _ _ m) = fromJust $ mapToTree 0 where
    mapToTree i = if i `M.notMember` m
                  then Nothing
                  else let i2 = 2 * i
                           bl = mapToTree (i2 + 1)
                           br = mapToTree (i2 + 2)
                       in Just $ BT (m M.! i) bl br

treeToMap :: M.Map Int a -> Int -> BinTree a -> M.Map Int a
treeToMap m i tree = let m' = M.insert i (btValue tree) m
                         i2 = 2 * i
                         m'' = maybe m' (treeToMap m' (i2 + 1)) (btLeft tree)
                     in maybe m'' (treeToMap m'' (i2 + 2)) (btRight tree)

                        
up :: Zipper a -> Maybe (Zipper a)
up (Zipper _ [] _)     = Nothing
up (Zipper i (u:us) m) = Just $ Zipper u us m

value :: Zipper a -> a
value (Zipper i _ m) = m M.! i

Tags:

construct:add
construct:application
construct:case
construct:data-declaration
construct:deriving
construct:dot
construct:field-label
construct:if-then-else
construct:implicit-parameter
construct:import
construct:int
construct:integral-number
construct:invocation
construct:lambda
construct:let
construct:list
construct:method
construct:module
construct:multiply
construct:named-argument
construct:parameter
construct:pattern-matching
construct:record-constructor
construct:recursion
construct:string
construct:underscore
construct:variable
construct:visibility-modifiers
paradigm:functional
paradigm:imperative
paradigm:metaprogramming
paradigm:object-oriented
technique:higher-order-functions
technique:looping
technique:recursion
uses:Data.List

[iHiD]

Exercise: trinary

Code

module Trinary (showTri, readTri) where

showTri :: Integral a => a -> String
showTri = showBase 3

readTri :: Integral a => String -> a
readTri = readBase 3

showBase :: Integral a => a -> a -> String
showBase _ 0 = "0"
showBase b n = go "" n
  where
    go s 0 = s
    go s n = let (d, m) = divMod n b in go (digitFor m : s) d

readBase :: Integral a => a -> String -> a
readBase b s = go s 0
  where
    go ""     n = n
    go (x:xs) n
      | x > digitFor b = 0
      | otherwise      = go xs $! n * b + valueOf x

digitFor :: Integral a => a -> Char
digitFor n = toEnum (fromIntegral n + fromEnum '0')

valueOf :: Integral a => Char -> a
valueOf x = fromIntegral (fromEnum x - fromEnum '0')

Tags:

construct:add
construct:char
construct:divide
construct:double
construct:floating-point-number
construct:function
construct:implicit-conversion
construct:integral-number
construct:invocation
construct:lambda
construct:let
construct:list
construct:local-definitions
construct:number
construct:parameter
construct:pattern-matching
construct:recursion
construct:string
construct:subtract
construct:underscore
construct:variable
construct:where
paradigm:functional
paradigm:imperative
paradigm:object-oriented
technique:higher-order-functions
technique:looping
technique:performance
uses:Show

[iHiD]

Exercise: dnd-character

Code

{-

For a game of Dungeons & Dragons, each player starts by generating a character they can play with. 
This character has, among other things, six abilities; 
strength, dexterity, constitution, intelligence, wisdom and charisma. 
These six abilities have scores that are determined randomly. 
You do this by rolling four 6-sided dice and record the sum of the largest three dice. 
You do this six times, once for each ability.

Your character's initial hitpoints are 10 + your character's constitution modifier. 
You find your character's constitution modifier by subtracting 10 from your character's constitution, divide by 2 and round down.

Write a random character generator that follows the rules above.

For example, the six throws of four dice may look like:

5, 3, 1, 6: You discard the 1 and sum 5 + 3 + 6 = 14, which you assign to strength.
3, 2, 5, 3: You discard the 2 and sum 3 + 5 + 3 = 11, which you assign to dexterity.
1, 1, 1, 1: You discard the 1 and sum 1 + 1 + 1 = 3, which you assign to constitution.
2, 1, 6, 6: You discard the 1 and sum 2 + 6 + 6 = 14, which you assign to intelligence.
3, 5, 3, 4: You discard the 3 and sum 5 + 3 + 4 = 12, which you assign to wisdom.
6, 6, 6, 6: You discard the 6 and sum 6 + 6 + 6 = 18, which you assign to charisma.
Because constitution is 3, the constitution modifier is -4 and the hitpoints are 6.

-}

module DND
  ( Character(..)
  , ability
  , modifier
  , character
  )
where

import           Test.QuickCheck                ( Gen
                                                , choose
                                                )
import           Data.List                      ( sort )
import           Control.Monad                  ( replicateM )

data Character = Character
  { strength     :: Int
  , dexterity    :: Int
  , constitution :: Int
  , intelligence :: Int
  , wisdom       :: Int
  , charisma     :: Int
  , hitpoints    :: Int
  }
  deriving (Show, Eq)

modifier :: Int -> Int
modifier = (`div` 2) . (\x -> x - 10)

ability :: Gen Int
ability = do
  list <- fiveDice
  return $ sum . drop 1 . sort $ list

fiveDice :: Gen [Int]
fiveDice = replicateM 4 . choose $ (1, 6)

character :: Gen Character
character = do 
  [str, dex, con, int, wis, cha] <- replicateM 6 ability
  return $ Character str dex con int wis cha (10 + modifier con)

Tags:

construct:add
construct:assignment
construct:char
construct:constructor
construct:data
construct:do
construct:field
construct:import
construct:int
construct:integral-number
construct:invocation
construct:lambda
construct:list
construct:method
construct:module
construct:number
construct:parameter
construct:pattern-matching
construct:return
construct:subtract
construct:tuple
construct:variable
construct:visibility-modifiers
paradigm:functional
paradigm:imperative
paradigm:object-oriented
technique:higher-order-functions

[ErikSchierboom]

This is an automated comment

Hello 👋 Next week we're going to start using the tagging work people are doing on these. If you've already completed the work, thank you! If you've not, but intend to this week, that's great! If you're not going to get round to doing it, and you've not yet posted a comment letting us know, could you please do so, so that we can find other people to do it. Thanks!