Skip to content

Instantly share code, notes, and snippets.

@gfixler

gfixler/gist:11363259

Last active Aug 29, 2015
Embed
What would you like to do?
Learn You A Haskell scratchpad
import Data.List
import Data.Char
import qualified Data.Map as Map
import qualified Data.Set as Set
factorial n = product [1..n]
dublist x = x ++ x
double x = x + x
quadruple x = (double . double) x
average ns = sum ns `div` length ns
first x = x !! 0
final x = first (reverse x)
ultimate x = x !! (length x - 1)
nth n x = final (take n x)
n = a `div` length xs
where
a = 10
xs = [1,2,3,4,5]
add' :: Int -> (Int -> Int)
add' x y = x + y
palindrome :: String -> Bool
palindrome xs = xs == reverse xs
myEven :: Integral a => a -> Bool
myEven n = n `mod` 2 == 0
mySplitAt :: Int -> [a] -> ([a],[a])
mySplitAt n xs = (take n xs, drop n xs)
myRecip :: Fractional a => a -> a
myRecip n = 1/n
myAbs :: Int -> Int
myAbs n = if n >= 0 then n else - n
mySignum :: Int -> Int
mySignum n = if n < 0 then -1 else
if n == 0 then 0 else 1
myGuardedSignum :: Int -> Int
myGuardedSignum n | n < 0 = -1
| n == 0 = 0
| otherwise = 1
myFst :: (a, b) -> a
myFst (x,_) = x
mySnd :: (a, b) -> b
mySnd (_,y) = y
test :: [Char] -> Bool
test ['a',_,_] = True
test _ = False
test2 :: [Char] -> Bool
test2 ('a':_) = True
test2 _ = False
myOdds :: Int -> [Int]
myOdds n = map f [0..n-1]
where f x = x * 2 + 1
myOdds2 :: Int -> [Int]
myOdds2 n = map(\x -> x * 2 + 1)[0..n-1]
always4711 :: a -> Int
always4711 _ = 4711
halve :: Ord a => [a] -> ([a],[a])
halve xs
| xs == [] = error "Can't halve an empty list!"
| even (length xs) = (take half xs, drop half xs)
| otherwise = error "Can't halve an odd-length list!"
where half = length xs `div` 2
(|||) :: Bool -> Bool -> Bool
True ||| True = True
True ||| False = True
False ||| True = True
False ||| False = False
(||||) :: Bool -> Bool -> Bool
False |||| False = False
_ |||| _ = True
safetail :: Eq a => [a] -> [a]
safetail x = if x == [] then [] else
drop 1 x
safetail2 :: [a] -> [a]
safetail2 x | null x = []
| otherwise = drop 1 x
safetail3 :: [a] -> [a]
safetail3 [] = []
safetail3 (a:as) = as
factors :: Int -> [Int]
factors n = [x | x <- [1..n], n `mod` x == 0]
prime :: Int -> Bool
prime n = factors n == [1,n]
primes :: Int -> [Int]
primes n = [x | x <- [2..n], prime x]
find' :: Eq a => a -> [(a,b)] -> [b]
find' k t = [v | (k',v) <- t, k == k']
pairs' :: [a] -> [(a,a)]
pairs' xs = zip xs (tail xs)
ordered :: Ord a => [a] -> Bool
ordered xs = and [x <= y | (x,y) <- pairs' xs]
positions :: Eq a => a -> [a] -> [Int]
positions x xs = [i | (x',i) <- zip xs [0..n], x == x']
where n = length xs - 1
isLetter :: Char -> Bool
isLetter c | any (== c) ['a'..'z'] = True
| otherwise = False
let2int :: Char -> Int
let2int c = first (positions c ['a'..'z'])
int2let :: Int -> Char
int2let n = first [c | (c,i) <- zip ['a'..'z'] [0..], n == i]
pyths :: Int -> [(Int,Int,Int)]
pyths n = [(x,y,z) | x <- [1..n], y <- [1..n], z <- [1..n], x^2 + y^2 == z^2]
butlast :: [a] -> [a]
butlast xs = reverse (tail (reverse xs))
perfects :: Int -> [Int]
perfects n = [x | x <- [1..n], sum (butlast (factors x)) == x]
shiftKey :: Int -> (Int,Float,Bool,Float,Float,String,String) -> (Int,Float,Bool,Float,Float,String,String)
shiftKey n (f,v,l,ia,oa,itt,ott) = (f+n,v,l,ia,oa,itt,ott)
gimme :: Int -> Int -> [Int]
gimme 0 x = []
gimme (n+1) x = x : replicate n x
-- http://learnyouahaskell.com/syntax-in-functions
lucky :: (Integral a) => a -> String
lucky 7 = "LUCKY NUMBER SEVEN!"
lucky x = "Sorry, you're out of luck, pal!"
sayMe :: (Integral a) => a -> String
sayMe 1 = "One!"
sayMe 2 = "Two!"
sayMe 3 = "Three!"
sayMe 4 = "Four!"
sayMe 5 = "Five!"
sayMe x = "Not between 1 and 5"
factorial' :: (Integral a) => a -> a
factorial' 0 = 1
factorial' n = n * factorial (n - 1)
charName :: Char -> String
charName 'a' = "Albert"
charName 'b' = "Broseph"
charName 'c' = "Cecil"
addVectors :: (Num a) => (a, a) -> (a, a) -> (a, a)
addVectors a b = (fst a + fst b, snd a + snd b)
addVectors' :: (Num a) => (a, a) -> (a, a) -> (a, a)
addVectors' (x1, y1) (x2, y2) = (x1 + x2, y1 + y2)
first' :: (a, b, c) -> a
first' (x, _, _) = x
second' :: (a, b, c) -> b
second' (_, y, _) = y
third' :: (a, b, c) -> c
third' (_, _, z) = z
head' :: [a] -> a
head' [] = error "Can't call head on an empty list, dummy!"
head' (x:_) = x
tell :: (Show a) => [a] -> String
tell [] = "The list is empty"
tell (x:[]) = "The list has one element: " ++ show x
tell (x:y:[]) = "The list has two elements: " ++ show x ++ " and " ++ show y
tell (x:y:_) = "This list is long. The first two elements are: " ++ show x ++ " and " ++ show y
length' :: (Num b) => [a] -> b
length' [] = 0
length' (_:xs) = 1 + length' xs
sum' :: (Num a) => [a] -> a
sum' [] = 0
sum' (x:xs) = x + sum' xs
capital :: String -> String
capital "" = "Empty string!"
capital all@(x:_) = "The first letter of " ++ all ++ " is " ++ [x]
bmiTell :: (RealFloat a) => a -> String
bmiTell bmi
| bmi <= 18.5 = "You're underewight, you emo you!"
| bmi <= 25.0 = "You're supposedly normal. Pffft, I bet you're ugly!"
| bmi <= 30.0 = "You're fat! Lose some weight, fatty!"
| otherwise = "You're a whale, congratulations!"
bmiTell' :: (RealFloat a) => a -> a -> String
bmiTell' weight height
| weight / height ^ 2 <= 18.5 = "You're underewight, you emo you!"
| weight / height ^ 2 <= 18.5 = "You're supposedly normal. Pffft, I bet you're ugly!"
| weight / height ^ 2 <= 18.5 = "You're fat! Lose some weight, fatty!"
| otherwise = "You're a whale, congratulations!"
max' :: (Ord a) => a -> a -> a
max' a b
| a > b = a
| otherwise = b
myCompare :: (Ord a) => a -> a -> Ordering
a `myCompare` b
| a < b = LT
| a == b = EQ
| otherwise = GT
bmiTell'' :: (RealFloat a) => a -> a -> String
bmiTell'' weight height
| bmi <= 18.5 = "You're underewight, you emo you!"
| bmi <= 25.0 = "You're supposedly normal. Pffft, I bet you're ugly!"
| bmi <= 30.0 = "You're fat! Lose some weight, fatty!"
| otherwise = "You're a whale, congratulations!"
where bmi = weight / height ^ 2
bmiTell''' :: (RealFloat a) => a -> a -> String
bmiTell''' weight height
| bmi <= skinny = "You're underewight, you emo you!"
| bmi <= normal = "You're supposedly normal. Pffft, I bet you're ugly!"
| bmi <= fat = "You're fat! Lose some weight, fatty!"
| otherwise = "You're a whale, congratulations!"
where bmi = weight / height ^ 2
skinny = 18.5
normal = 25.0
fat = 30.0
bmiTell'''' :: (RealFloat a) => a -> a -> String
bmiTell'''' weight height
| bmi <= skinny = "You're underewight, you emo you!"
| bmi <= normal = "You're supposedly normal. Pffft, I bet you're ugly!"
| bmi <= fat = "You're fat! Lose some weight, fatty!"
| otherwise = "You're a whale, congratulations!"
where bmi = weight / height ^ 2
(skinny, normal, fat) = (18.5, 25.0, 30.0)
initials :: String -> String -> String
initials (a:_) (b:_) = "Your initials are " ++ [a] ++ "." ++ [b] ++ "."
initials' :: String -> String -> String
initials' firstname lastname = [f] ++ ". " ++ [l] ++ "."
where (f:_) = firstname
(l:_) = lastname
calcBmis :: (RealFloat a) => [(a, a)] -> [a]
calcBmis xs = [bmi w h | (w, h) <- xs]
where bmi weight height = weight / height ^ 2
cylinder :: (RealFloat a) => a -> a -> a
cylinder r h =
let sideArea = 2 * pi * r * h
topArea = pi * r ^ 2
in sideArea + 2 * topArea
calcBmis' :: (RealFloat a) => [(a, a)] -> [a]
calcBmis' xs = [bmi | (w, h) <- xs, let bmi = w / h ^ 2]
calcFatBmis :: (RealFloat a) => [(a, a)] -> [a]
calcFatBmis xs = [bmi | (w, h) <- xs, let bmi = w / h ^ 2, bmi >= 25.0]
headcase :: [a] -> a
headcase xs = case xs of [] -> error "No head for empty lists!"
(x:_) -> x
describeList :: [a] -> String
describeList xs = "The list is " ++ case xs of [] -> "empty."
[x] -> "a singleton list."
xs -> "a longer list."
describeList' :: [a] -> String
describeList' xs = "The list is " ++ what xs
where what [] = "empty."
what [x] = "a singleton list."
what xs = "a longer list."
-- http://learnyouahaskell.com/recursion
maximum' :: (Ord a) => [a] -> a
maximum' [] = error "maximum of empty list"
maximum' [x] = x
maximum' (x:xs)
| x > maxTail = x
| otherwise = maxTail
where maxTail = maximum' xs
maximum'' :: (Ord a) => [a] -> a
maximum'' [] = error "maximum of empty list"
maximum'' [x] = x
maximum'' (x:xs) = max x (maximum' xs)
replicate' :: (Num i, Ord i) => i -> a -> [a]
replicate' n x
| n <= 0 = []
| otherwise = x:replicate' (n-1) x
take' :: (Num i, Ord i) => i -> [a] -> [a]
take' n _
| n <= 0 = []
take' _ [] = []
take' n (x:xs) = x : take' (n-1) xs
-- this one is mine; just testing things out
surround :: (Num i, Ord i) => i -> String -> String
surround n s
| n <= 0 = s
| otherwise = "(" ++ (surround (n-1) s) ++ ")"
reverse' :: [a] -> [a]
reverse' [] = []
reverse' (x:xs) = reverse' xs ++ [x]
repeat' :: a -> [a]
repeat' x = x:repeat' x
zip' :: [a] -> [b] -> [(a,b)]
zip' _ [] = []
zip' [] _ = []
zip' (x:xs) (y:ys) = (x,y):zip' xs ys
elem' :: (Eq a) => a -> [a] -> Bool
elem' a [] = False
elem' a (x:xs)
| a == x = True
| otherwise = a `elem'` xs
quicksort :: (Ord a) => [a] -> [a]
quicksort [] = []
quicksort (x:xs) =
let smallerSorted = quicksort [a | a <- xs, a <= x]
biggerSorted = quicksort [a | a <- xs, a > x]
in smallerSorted ++ [x] ++ biggerSorted
-- http://learnyouahaskell.com/higher-order-functions
multThree :: (Num a) => a -> a -> a -> a
multThree x y z = x * y * z
compareWithHundred :: (Num a, Ord a) => a -> Ordering
compareWithHundred x = compare 100 x
divideByTen :: (Floating a) => a -> a
divideByTen = (/10)
isUpperAlphanum :: Char -> Bool
isUpperAlphanum = (`elem` ['A'..'Z'])
applyTwice :: (a -> a) -> a -> a
applyTwice f x = f (f x)
zipWith' :: (a -> b -> c) -> [a] -> [b] -> [c]
zipWith' _ [] _ = []
zipWith' _ _ [] = []
zipWith' f (x:xs) (y:ys) = f x y : zipWith' f xs ys
flip' :: (a -> b -> c) -> (b -> a -> c)
flip' f = g
where g x y = f y x
flip'' :: (a -> b -> c) -> b -> a -> c
flip'' f y x = f x y
map' :: (a -> b) -> [a] -> [b]
map' _ [] = []
map' f (x:xs) = f x : map f xs
filter' :: (a -> Bool) -> [a] -> [a]
filter' _ [] = []
filter' p (x:xs)
| p x = x : filter' p xs
| otherwise = filter' p xs
quicksort' :: (Ord a) => [a] -> [a]
quicksort' [] = []
quicksort' (x:xs) =
let smallerSorted = quicksort' (filter (<=x) xs)
biggerSorted = quicksort' (filter (>x) xs)
in smallerSorted ++ [x] ++ biggerSorted
largestDivisible :: (Integral a) => a
largestDivisible = head (filter p [100000,99999..])
where p x = x `mod` 3829 == 0
chain :: (Integral a) => a -> [a]
chain 1 = [1]
chain n
| even n = n:chain (n `div` 2)
| odd n = n:chain (n*3 + 1)
numLongChains :: Int
numLongChains = length (filter isLong (map chain [1..100]))
where isLong xs = length xs > 15
numLongChains' :: Int
numLongChains' = length (filter (\xs -> length xs > 15) (map chain [1..100]))
addThree :: (Num a) => a -> a -> a -> a
addThree x y z = x + y + z
addThree' :: (Num a) => a -> a -> a -> a
addThree' = \x -> \y -> \z -> x + y + z
flip''' :: (a -> b -> c) -> b -> a -> c
flip''' f = \x y -> f y x
sum'' :: (Num a) => [a] -> a
sum'' xs = foldl (\acc x -> acc + x) 0 xs
sum''' :: (Num a) => [a] -> a
sum''' = foldl (+) 0
elem'' :: (Eq a) => a -> [a] -> Bool
elem'' y ys = foldl (\acc x -> if x == y then True else acc) False ys
map'' :: (a -> b) -> [a] -> [b]
map'' f xs = foldr (\x acc -> f x : acc) [] xs
foldMaximum :: (Ord a) => [a] -> a
foldMaximum = foldr1 (\x acc -> if x > acc then x else acc)
foldReverse :: [a] -> [a]
foldReverse = foldl (\acc x -> x : acc) []
foldProduct :: (Num a) => [a] -> a
foldProduct = foldr1 (*)
foldFilter :: (a -> Bool) -> [a] -> [a]
foldFilter p = foldr (\x acc -> if p x then x : acc else acc) []
foldHead :: [a] -> a
foldHead = foldr1 (\x _ -> x)
foldLast :: [a] -> a
foldLast = foldl1 (\_ x -> x)
sqrtSums :: Int
sqrtSums = length (takeWhile (<1000) (scanl1 (+) (map sqrt [1..]))) + 1
oddSquareSum :: Integer
oddSquareSum = sum (takeWhile (<10000) (filter odd (map (^2) [1..])))
oddSquareSum' :: Integer
oddSquareSum' = sum . takeWhile (<10000) . filter odd . map (^2) $ [1..]
oddSquareSum''' :: Integer
oddSquareSum''' =
let oddSquares = filter odd $ map (^2) [1..]
belowLimit = takeWhile (<10000) oddSquares
in sum belowLimit
-- http://learnyouahaskell.com/modules
search :: (Eq a) => [a] -> [a] -> Bool
search needle haystack =
let nlen = length needle
in foldl (\acc x -> if take nlen x == needle then True else acc) False (tails haystack)
encode :: Int -> String -> String
encode shift msg =
let ords = map ord msg
shifted = map (+ shift) ords
in map chr shifted
encode' :: Int -> String -> String
encode' shift = map (chr . (+ shift) . ord)
phoneBook =
[("betty","555-2938")
,("bonnie","452-2928")
,("patsy","493-2928")
,("lucille","205-2928")
,("wendy","939-8282")
,("penny","853-2492")
]
findKey :: (Eq k) => k -> [(k,v)] -> v
findKey key xs = snd . head . filter (\(k,v) -> key == k) $ xs
findKey' :: (Eq k) => k -> [(k,v)] -> Maybe v
findKey' key [] = Nothing
findKey' key ((k,v):xs) = if key == k
then Just v
else findKey' key xs
findKey'' :: (Eq k) => k -> [(k,v)] -> Maybe v
findKey'' key = foldr (\(k,v) acc -> if key == k then Just v else acc) Nothing
fromList' :: (Ord k) => [(k,v)] -> Map.Map k v
fromList' = foldr (\(k,v) acc -> Map.insert k v acc) Map.empty
phoneBook2 =
[("betty","555-2938")
,("betty","342-2492")
,("bonnie","452-2928")
,("patsy","493-2928")
,("patsy","943-2929")
,("patsy","827-9162")
,("lucille","205-2928")
,("wendy","939-8282")
,("penny","853-2492")
,("penny","555-2111")
]
phoneBookToMap :: (Ord k) => [(k, String)] -> Map.Map k String
phoneBookToMap xs = Map.fromListWith (\number1 number2 -> number1 ++ ", " ++ number2) xs
phoneBookToMap' :: (Ord k) => [(k, a)] -> Map.Map k [a]
phoneBookToMap' xs = Map.fromListWith (++) $ map (\(k,v) -> (k,[v])) xs
-- http://learnyouahaskell.com/making-our-own-types-and-typeclasses
data Shape' = Circle' Float Float Float | Rectangle' Float Float Float Float deriving (Show)
surface' :: Shape' -> Float
surface' (Circle' _ _ r) = pi * r ^ 2
surface' (Rectangle' x1 y1 x2 y2) = (abs $ x2 - x1) * (abs $ y2 -y1)
data Point = Point Float Float deriving (Show)
data Shape = Circle Point Float | Rectangle Point Point deriving (Show)
surface :: Shape -> Float
surface (Circle _ r) = pi * r ^ 2
surface (Rectangle (Point x1 y1) (Point x2 y2)) = (abs $ x2 - x1) * (abs $ y2 - y1)
nudge :: Shape -> Float -> Float -> Shape
nudge (Circle (Point x y) r) a b = Circle (Point (x+a) (y+b)) r
nudge (Rectangle (Point x1 y1) (Point x2 y2)) a b = Rectangle (Point (x1+a) (y1+b)) (Point (x2+a) (y2+b))
baseCircle :: Float -> Shape
baseCircle r = Circle (Point 0 0) r
baseRect :: Float -> Float -> Shape
baseRect w h = Rectangle (Point 0 0) (Point w h)
data Person' = Person' String String Int Float String String deriving (Show)
firstName' :: Person' -> String
firstName' (Person' firstname _ _ _ _ _) = firstname
lastName' :: Person' -> String
lastName' (Person' _ lastname _ _ _ _) = lastname
age' :: Person' -> Int
age' (Person' _ _ age _ _ _) = age
height' :: Person' -> Float
height' (Person' _ _ _ height _ _) = height
phoneNumber' :: Person' -> String
phoneNumber' (Person' _ _ _ _ number _) = number
flavor' :: Person' -> String
flavor' (Person' _ _ _ _ _ flavor) = flavor
data Person = Person { firstName :: String
, lastName :: String
, age :: Int
, height :: Float
, phoneNumber :: String
, flavor :: String
} deriving (Show)
data Vector a = Vector a a a deriving (Show)
vplus :: (Num t) => Vector t -> Vector t -> Vector t
(Vector i j k) `vplus` (Vector l m n) = Vector (i+l) (j+m) (k+n)
vectMult :: (Num t) => Vector t -> t -> Vector t
(Vector i j k) `vectMult` m = Vector (i*m) (j*m) (k*m)
scalarMult :: (Num t) => Vector t -> Vector t -> t
(Vector i j k) `scalarMult` (Vector l m n) = i*l + j*m + k*n
data ComparablePerson = ComparablePerson { cp_firstName :: String
, cp_lastName :: String
, cp_age :: Int
} deriving (Eq, Show, Read)
data Day = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday
deriving (Eq, Ord, Show, Read, Bounded, Enum)
data LockerState = Taken | Free deriving (Show, Eq)
type Code = String
type LockerMap = Map.Map Int (LockerState, Code)
lockerLookup :: Int -> LockerMap -> Either String Code
lockerLookup lockerNumber map =
case Map.lookup lockerNumber map of
Nothing -> Left $ "Locker number " ++ show lockerNumber ++ " doesn't exist!"
Just (state, code) -> if state /= Taken
then Right code
else Left $ "Locker " ++ show lockerNumber ++ " is already taken!"
lockers :: LockerMap
lockers = Map.fromList
[(100,(Taken,"ZD39I"))
,(101,(Free,"JAH3I"))
,(103,(Free,"IQSA9"))
,(105,(Free,"QOTSA"))
,(109,(Taken,"893JJ"))
,(110,(Taken,"99292"))
]
data List' a = Empty' | Cons a (List' a) deriving (Show, Read, Eq, Ord)
infixr 5 :-:
data List a = Empty | a :-: (List a) deriving (Show, Read, Eq, Ord)
infixr 5 .++
(.++) :: List a -> List a -> List a
Empty .++ ys = ys
(x :-: xs) .++ ys = x :-: (xs .++ ys)
data Tree a = EmptyTree | Node a (Tree a) (Tree a) deriving (Show, Read, Eq)
singleton :: a -> Tree a
singleton x = Node x EmptyTree EmptyTree
treeInsert :: (Ord a) => a -> Tree a -> Tree a
treeInsert x EmptyTree = singleton x
treeInsert x (Node a left right)
| x == a = Node x left right
| x < a = Node a (treeInsert x left) right
| x > a = Node a left (treeInsert x right)
treeElem :: (Ord a) => a -> Tree a -> Bool
treeElem x EmptyTree = False
treeElem x (Node a left right)
| x == a = True
| x < a = treeElem x left
| x > a = treeElem x right
data TrafficLight = Red | Yellow | Green
instance Eq TrafficLight where
Red == Red = True
Green == Green = True
Yellow == Yellow = True
_ == _ = False
instance Show TrafficLight where
show Red = "Red Light"
show Yellow = "Yellow Light"
show Green = "Green Light"
class YesNo a where
yesno :: a -> Bool
instance YesNo Int where
yesno 0 = False
yesno _ = True
instance YesNo [a] where
yesno [] = False
yesno _ = True
instance YesNo Bool where
yesno = id
instance YesNo (Maybe a) where
yesno (Just _) = True
yesno Nothing = False
instance YesNo (Tree a) where
yesno EmptyTree = False
yesno _ = True
instance YesNo TrafficLight where
yesno Red = False
yesno _ = True
yesnoIf :: (YesNo y) => y -> a -> a -> a
yesnoIf yesnoVal yesResult noResult = if yesno yesnoVal then yesResult else noResult
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment