Skip to content

Instantly share code, notes, and snippets.

@shkesar

shkesar/Main.hs

Last active June 5, 2019 11:35
Show Gist options
  • Save shkesar/3f88d79bba837a079a402aee4273bed6 to your computer and use it in GitHub Desktop.
Save shkesar/3f88d79bba837a079a402aee4273bed6 to your computer and use it in GitHub Desktop.
Download ZIP
Learning Haskell - Programming in Haskell - Graham Hutton
Raw
Main.hs
module Main where
import Lib
import Data.Char
import Prelude
import Text.Printf
main :: IO ()
main = someFunc
qsort [] = []
qsort (x:xs) = qsort smaller ++ [x] ++ qsort larger
where
smaller = [a | a <- xs, a <= x]
larger = [b | b <- xs, b > x]
--qsort [3,5,1,4,2]
seqn :: [IO a] -> IO [a]
seqn [] = return []
seqn (act:acts) = do x <- act
xs <- seqn acts
return (x:xs)
factorial n = product [1..n]
average ns = sum ns `div` length ns
add x y = x + y
-- Pattern matching
--(&&) :: Bool -> Bool -> Bool
--True && True = True
--_ && _ = False
-- lambda expressions
a = \ x -> x + x
addL :: Int -> (Int -> Int)
addL = \ x -> \ y -> x + y
add2 = addL 2
-- function declaration is right associative
-- function application is left associative
-- luhn algorithm
luhnDouble :: Int -> Int
luhnDouble x = y - (if y > 9 then 9 else 0) where y = x * 2
--luhn :: Int -> Int -> Int -> Int -> Bool
--luhn a b c d = sum (map luhnDouble [a,c]) `mod` 10 == 0
-- guards
--find :: Eq a => a -> [(a,b)] -> [b]
--find k t = [v | (k', v) <- t, k == k']
-- zip
pairs :: [a] -> [(a,a)]
pairs xs = zip xs (tail xs)
sorted :: Ord a => [a] -> Bool
sorted xs = and [x <= y | (x,y) <- pairs xs]
positions :: Eq a => a -> [a] -> [Int]
positions x xs = [i | (x', i) <- zip xs [0..], x == x']
-- Caesar Cipher
let2int :: Char -> Int
let2int c = ord c - ord 'a'
int2let :: Int -> Char
int2let n = chr (ord 'a' + n)
shift :: Int -> Char -> Char
shift n c | isLower c = int2let ((let2int c + n) `mod` 26)
| otherwise = c
--encode :: Int -> String -> String
--encode n xs = [shift n x | x <- xs]
percent :: Int -> Int -> Float
percent n m = (fromIntegral n / fromIntegral m) * 100
count :: Eq a => a -> [a] -> Int
count x xs = sum [1 | x' <- xs, x == x']
lowers :: String -> Int
lowers xs = length [x | x <- xs, isAsciiLower x]
freqs :: String -> [Float]
freqs xs = [percent (count x xs) n | x <- ['a'..'z']]
where
n = lowers xs
-------------
-- Recursion
-- Some of the implementations are commented because they are
-- overriding the existing definitions in scope
-------------
fac :: Int -> Int
fac 0 = 1
fac n = n * fac(n-1)
--product :: Num a => [a] -> a
--product [] = 1
--product (n:ns) = n * product ns
--length :: [a] -> Int
--length [] = 0
--length (_:xs) = 1 + length xs
--reverse :: [a] -> [a]
--reverse [] = []
--reverse (x:xs) = reverse(xs) ++ [x]
-- commented because above qsort code is using system ++
--(++) :: [a] -> [a] -> [a]
--[] ++ ys = ys
--(x:xs) ++ ys = x : (xs :: ys)
insert :: Ord a => a -> [a] -> [a]
insert x [] = [x]
insert x (y:ys) | x <= y = x : y : ys
| otherwise = y : insert x ys
isort :: Ord a => [a] -> [a]
isort [] = []
isort (x:xs) = insert x (isort xs)
-- multiple arguments
--zip :: [a] -> [b] -> [(a,b)]
--zip [] _ = []
--zip _ [] = []
--zip (x:xs) (y:ys) = (x,y) : zip xs ys
--drop :: Int -> [a] -> [a]
--drop 0 xs = xs
--drop _ [] = []
--drop n (_:xs) = drop (n-1) xs
fib :: Int -> Int
fib 0 = 0
fib 1 = 1
fib n = fib (n-2) + fib(n-1)
-- mutual recursion
--even :: Int -> Bool
--even 0 = True
--even n = odd (n-1)
--
--odd :: Int -> Bool
--odd = False
--odd n = even (n + 1)
evens :: [a] -> [a]
evens [] = []
evens (x:xs) = x : odds xs
odds :: [a] -> [a]
odds [] = []
odds (x:xs) = evens xs
-------------------------
-- Higher order functions
-------------------------
twice :: (a -> a) -> a -> a
twice f x = f (f x)
--map :: (a -> b) -> [a] -> b
--map f xs = [f x | x <- xs]
--filter :: (a -> Bool) -> [a] -> [a]
--filter p xs = [x | x <- xs, p x]
-- filter using recursion
--filter p [] = []
--filter p (x:xs) | p x = x : filter p xs
-- | otherwise filter p xs
--foldr :: (a -> b -> b) -> b -> [a] -> b
--foldr f v [] = v
--foldr f v (x:xs) = f x (foldr f v xs)
--foldl :: (a -> b -> a) -> a -> [b] -> a
--foldl f v [] = v
--foldl f v (x:xs) = foldl f (f v x) xs
--sum :: Num a => [a] -> a
--sum = sum' 0
-- where
-- sum' v [] = v
-- sum' v (x:xs) = sum' (v+x) xs
--(.) :: (b -> c) -> (a -> b) -> (a -> c)
--f . g = \x -> f (g x)
type Bit = Int
bin2int :: [Bit] -> Int
bin2int bits = sum [w*b | (w,b) <- zip weights bits]
where weights = iterate (*2) 1
int2bin :: Int -> [Bit]
int2bin 0 = []
int2bin n = n `mod` 2 : int2bin(n `div` 2)
make8 :: [Bit] -> [Bit]
make8 bits = take 8 (bits ++ repeat 0)
encode :: String -> [Bit]
encode = concatMap (make8 . int2bin . ord)
chop8 :: [Bit] -> [[Bit]]
chop8 [] = []
chop8 bits = take 8 bits : chop8 (drop 8 bits)
decode :: [Bit] -> String
decode = map (chr . bin2int) . chop8
------------------------------
-- Declaring types and classes
------------------------------
type Pair a = (a,a)
type Assoc k v = [(k,v)]
find :: Eq k => k -> Assoc k v -> v
find k t = head [v | (k', v) <- t, k == k']
data Move = North | South | East | West
type Pos = (Int, Int)
move :: Move -> Pos -> Pos
move North (x,y) = (x, y+1)
move South (x,y) = (x, y-1)
move East (x,y) = (x+1, y)
move West (x,y) = (x-1, y)
data Shape = Circle Float | Rect Float Float
area :: Shape -> Float
area (Circle r) = pi * r^2
area (Rect l b) = l * b
safediv :: Int -> Int -> Maybe Int
safediv _ 0 = Nothing
safediv m n = Just (m `div` n)
-- Natural Numbers
data Nat = Zero | Succ Nat
instance Show Nat where
show Zero = "Zero"
show (Succ m) = printf "Succ (%s)" (show m)
nat2int :: Nat -> Int
nat2int Zero = 0
nat2int (Succ n) = 1 + nat2int n
int2nat :: Int -> Nat
int2nat 0 = Zero
int2nat n = Succ (int2nat (n-1))
add' :: Nat -> Nat -> Nat
add' Zero n = n
add' (Succ m) n = Succ (add' m n)
addNat :: Nat -> Nat -> Nat
addNat m n = int2nat (nat2int m + nat2int n)
-- List
data List' a = Nil | Cons a (List' a)
len :: List' a -> Int
len Nil = 0
len (Cons _ xs) = 1 + len xs
-- Tree
data Tree a = Leaf a | Node (Tree a) a (Tree a)
t :: Tree Int
t = Node (Node (Leaf 1) 3 (Leaf 4))
5
(Node (Leaf 6) 7 (Leaf 9))
occurs :: Eq a => a -> Tree a -> Bool
occurs x (Leaf y) = x == y
occurs x (Node l y r) = (x == y) || occurs x l || occurs x r
flatten :: Tree a -> [a]
flatten (Leaf x) = [x]
flatten (Node l x r) = flatten l ++ [x] ++ flatten r
occurs' :: Ord a => a -> Tree a -> Bool
occurs' x (Leaf y) = x == y
occurs' x (Node l y r) | x == y = True
| x < y = occurs x l
| otherwise = occurs x r
-- class
class Bird a where
eat, walk, fly :: () -> a
-- Tautology checker
data Prop = Const Bool
| Var Char
| Not Prop
| And Prop Prop
| Imply Prop Prop
p1 :: Prop
p1 = And (Var 'A') (Not (Var 'A'))
p2 :: Prop
p2 = Imply (And (Var 'A') (Var 'B')) (Var 'A')
p3 :: Prop
p3 = Imply (Var 'A') (And (Var 'A') (Var 'B'))
p4 :: Prop
p4 = Imply (And (Var 'A') (Imply (Var 'A') (Var 'B'))) (Var 'B')
type Subst = Assoc Char Bool
eval :: Subst -> Prop -> Bool
eval _ (Const b) = b
eval s (Var x) = find x s
eval s (Not p) = not (eval s p)
eval s (And p q) = eval s p && eval s q
eval s (Imply p q) = eval s p <= eval s q
vars :: Prop -> [Char]
vars (Const _) = []
vars (Var x) = [x]
vars (Not p) = vars p
vars (And p q) = vars p ++ vars q
vars (Imply p q) = vars p ++ vars q
bools :: Int -> [[Bool]]
bools n = map (reverse . map conv . make n . int2bin) range
where
range = [0..(2^n)-1]
make n bs = take n (bs ++ repeat 0)
conv 0 = False
conv 1 = True
rmdups :: Eq a => [a] -> [a]
rmdups [] = []
rmdups (x:xs) = x : filter (/= x) (rmdups xs)
substs :: Prop -> [Subst]
substs p = map (zip vs) (bools (length vs))
where vs = rmdups (vars p)
isTaut :: Prop -> Bool
isTaut p = and [eval s p | s <- substs p]
-- Abstract Machine
data Expr = Val Int | Add Expr Expr
value :: Expr -> Int
value (Val n) = n
value (Add x y) = value x + value y
type Cont = [Op]
data Op = EVAL Expr | ADD Int
eval' :: Expr -> Cont -> Int
eval' (Val n) c = exec c n
eval' (Add x y) c = eval' x (EVAL y : c)
exec :: Cont -> Int -> Int
exec [] n = n
exec (EVAL y : c) n = eval' y (ADD n : c)
exec (ADD n : c) m = exec c (n+m)
value :: Expr -> Int
value e = eval e []
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment