Instantly share code, notes, and snippets.

Last active April 26, 2023 01:11
Show Gist options
• Save tkshill/2b26a9a04a3d6bd9cda15fb4381da703 to your computer and use it in GitHub Desktop.
Solving the Exercism Diamond problem using Haskell

# Diamond

The diamond kata takes as its input a letter, and outputs it in a diamond shape. Given a letter, it prints a diamond starting with 'A', with the supplied letter at the widest point.

## Requirements

• The first row contains one 'A'.
• The last row contains one 'A'.
• All rows, except the first and last, have exactly two identical letters.
• All rows have as many trailing spaces as leading spaces. (This might be 0).
• The diamond is horizontally symmetric.
• The diamond is vertically symmetric.
• The diamond has a square shape (width equals height).
• The letters form a diamond shape.
• The top half has the letters in ascending order.
• The bottom half has the letters in descending order.
• The four corners (containing the spaces) are triangles.

## Examples

In the following examples, spaces are indicated by `·` characters.

Diamond for letter 'A':

``````A
``````

Diamond for letter 'C':

``````··A··
·B·B·
C···C
·B·B·
··A··
``````

Diamond for letter 'E':

``````····A····
···B·B···
··C···C··
·D·····D·
E·······E
·D·····D·
··C···C··
···B·B···
····A····
``````
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode characters
 module Diamond (diamond) where import Data.Char (isAlpha, toUpper) import Data.List (unfoldr) -- Alias for char used when we specifically want a letter of the alphabet type Letter = Char -- main function. Accepts a character and (if it's a letter) returns a 'diamond' of letters diamond :: Char -> Maybe [String] diamond character | (not . isAlpha) character = Nothing -- fails on non Letter characters diamond letter = Just \$ missyElliott \$ unfoldr (rowMaker letter) letter where -- take the tail of the list and stick it upside down on the head missyElliott thang = reverse (tail thang) ++ thang -- accepts a character and (if it's a letter), returns the appropriate row in the diamond -- we can use currying to use this with unfold rowMaker :: Letter -> Char -> Maybe (String, Char) rowMaker _ char | toInt char < 0 = Nothing -- character number less that zero means not alphabetic rowMaker maxLetter currentLetter = Just (update initialRow, nextLetter) where nextLetter = toLetter \$ toInt currentLetter - 1 rowSize = (2 * toInt maxLetter) + 1 initialRow = replicate rowSize ' ' -- get the positions the character should be inserted at leftIndex = toInt maxLetter - toInt currentLetter rightIndex = rowSize - leftIndex - 1 -- replaces the value at position (i) in list xs with new value, (val) replace i val xs = take i xs ++ val : drop (i + 1) xs update xs = replace leftIndex currentLetter \$ replace rightIndex currentLetter xs -- convert the letter to a number with 'A' -> 0, 'B' -> 1, 'C' -> 2, etc.. -- based on the fact that uppercase ASCII characters start at 65 toInt :: Letter -> Int toInt letter = fromEnum (toUpper letter) - 65 toLetter :: Int -> Letter toLetter num = toEnum \$ num + 65
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode characters
 {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} import Data.Char (isLetter, isPrint, isSpace) import Data.Foldable (for_) import Data.List (isSuffixOf) import Data.Maybe (isJust, isNothing) import Data.String.Conversions (convertString) import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec.Runner (configFastFail, defaultConfig, hspecWith) import Test.QuickCheck (arbitraryASCIIChar, conjoin, counterexample, discard, elements, forAll, forAllShrink, Gen, Property, suchThat, Testable, (===)) import Diamond (diamond) main :: IO () main = hspecWith defaultConfig {configFastFail = True} specs specs :: Spec specs = describe "diamond" \$ do it "should not have a result for a non-alpha character" \$ forAllShrink genNonAlphaChar shrinkNonAlphaChar \$ isNothing . diamond it "should produce a value for an alpha character" \$ forAll genAlphaChar \$ isJust . diamond it "should have an odd number of rows" \$ forAllDiamond \$ odd . length it "should have equal top and bottom" \$ forAllDiamond \$ \rows -> let halfRoundDown = length rows `div` 2 in take halfRoundDown rows === take halfRoundDown (reverse rows) it "should have the same width and height" \$ forAllDiamond \$ \rows -> let sameHeightWidth idx row = counterexample (concat [ "The length of row with index " , show idx , " is not equal to the height" ]) (length row === length rows) in conjoin \$ zipWith sameHeightWidth [0 :: Int ..] rows it "rows should start and end with the same letter" \$ forAllDiamond \$ let headEqualsLast row = not (null row) && take 1 row `isSuffixOf` row in (&&) <\$> not . null <*> all (headEqualsLast . filter (not . isSpace)) for_ cases test where test Case{..} = it description assertion where assertion = (fmap . fmap) convertString (diamond input) `shouldBe` Just expected data Case = Case { description :: String , input :: Char , expected :: [String] } cases :: [Case] cases = [ Case { description = "Degenerate case with a single 'A' row" , input = 'A' , expected = ["A"] } , Case { description = "Degenerate case with no row containing 3 distinct groups of spaces" , input = 'B' , expected = [" A ", "B B", " A "] } , Case { description = "Smallest non-degenerate case with odd diamond side length" , input = 'C' , expected = [" A ", " B B ", "C C", " B B ", " A "] } , Case { description = "Smallest non-degenerate case with even diamond side length" , input = 'D' , expected = [" A ", " B B ", " C C ", "D D", " C C ", " B B ", " A "] } , Case { description = "Largest possible diamond" , input = 'Z' , expected = [ " A ", " B B ", " C C ", " D D ", " E E ", " F F ", " G G ", " H H ", " I I ", " J J ", " K K ", " L L ", " M M ", " N N ", " O O ", " P P ", " Q Q ", " R R ", " S S ", " T T ", " U U ", " V V ", " W W ", " X X ", " Y Y ", "Z Z", " Y Y ", " X X ", " W W ", " V V ", " U U ", " T T ", " S S ", " R R ", " Q Q ", " P P ", " O O ", " N N ", " M M ", " L L ", " K K ", " J J ", " I I ", " H H ", " G G ", " F F ", " E E ", " D D ", " C C ", " B B ", " A "] } ] genNonAlphaChar :: Gen Char genNonAlphaChar = arbitraryASCIIChar `suchThat` (not . isLetter) genAlphaChar :: Gen Char genAlphaChar = elements ['A'..'Z'] genDiamond :: Gen (Maybe [String]) genDiamond = (fmap . fmap . fmap) convertString \$ diamond <\$> genAlphaChar forAllDiamond :: Testable prop => ([String] -> prop) -> Property forAllDiamond p = forAll genDiamond \$ maybe discard p shrinkNonAlphaChar :: Char -> String shrinkNonAlphaChar c = if isPrint c then takeWhile (/= c) printableChars else printableChars where printableChars = filter isPrint ['\0' .. '\127']

### ghost commented Apr 27, 2021

Looks really cool

Thank you!