[Haskell] CIS 194: Homework 5-8

文章目录

Type classes
HomeWork 5
Lazy evaluation
HomeWork 6
folds-monoids
HomeWork 7
IO
HomeWork 8

Type classes

type classes:对类型进行操作的类
type-class polymorphic：类型类多态，相当于type classes的接口函数
所以类型类Eq a =>进行类型约束，标志着a类型必须实现了==和/=

关于Gradual Typing
静态和动态的概念总是容易混淆，Gradual Typing指的是允许程序的一部分使用动态类型（Dynamically typed）而另一部分使用静态类型（Statically typed）。
之前说的static-level和static-level则是指的在编译期或者运行时执行的语句块。

HomeWork 5

{-# OPTIONS_GHC -Wall -Werror #-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}module Calc whereimport ExprT ( ExprT(..) )
import Parser ( parseExp )
import StackVM
import Data.Maybe
import qualified Data.Map as Meval :: ExprT -> Integer
eval (ExprT.Lit n) = n
eval (ExprT.Add a b) = eval a + eval b
eval (ExprT.Mul a b) = eval a * eval b-- parseExp :: (Integer -> a) -> (a -> a -> a) -> (a -> a -> a) -> String -> Maybe a
evalStr :: String -> Maybe Integer
evalStr = fmap eval . parseExp ExprT.Lit ExprT.Add ExprT.Mulclass Expr a wherelit :: Integer -> aadd :: a -> a -> amul :: a -> a -> ainstance Expr ExprT wherelit = ExprT.Litadd = ExprT.Addmul = ExprT.Mul-- 通过一个实例方法来实现约束
reify :: ExprT -> ExprT
reify = idinstance Expr Integer wherelit = idadd = (+)mul = (*)instance Expr Bool wherelit x| x <= 0    = False| otherwise = Trueadd = (||)mul = (&&)newtype MinMax = MinMax Integer deriving (Eq, Show)instance Expr MinMax wherelit = MinMaxadd (MinMax x) (MinMax y)= MinMax (max x y)mul (MinMax x) (MinMax y)= MinMax (min x y)newtype Mod7 = Mod7 Integer deriving (Eq, Show)instance Expr Mod7 wherelit x = Mod7 (x `mod` 7)add (Mod7 x) (Mod7 y)= Mod7 ((x + y) `mod` 7)mul (Mod7 x) (Mod7 y)= Mod7 ((x * y) `mod` 7)testExp :: Expr a => Maybe a
testExp = parseExp lit add mul "(3 * -4) + 5"testInteger :: Maybe Integer
testInteger = testExptestBool :: Maybe Bool
testBool = testExptestMM :: Maybe MinMax
testMM = testExptestSat :: Maybe Mod7
testSat = testExpinstance Expr StackVM.Program wherelit i = [StackVM.PushI i]add a b = a ++ b ++ [StackVM.Add]mul a b = a ++ b ++ [StackVM.Mul]testProg :: Maybe StackVM.Program
testProg = testExpcompile2 :: String -> Either String StackVal
compile2 = stackVM . fromMaybe [] . compilecompile :: String -> Maybe Program
compile = parseExp lit add mulmain :: IO ()
main    =   doprint(reify $ mul  (add (lit 2) (lit 3)) (lit 4))

Lazy evaluation

Lazy evaluation在sml中已经接触的够多了，我们来考虑一组有趣的PL问题：（以下内容转自 https://www.zhihu.com/question/314434687/answer/628101937 以及维基百科作者知乎id头鱼）

Protocol，Interface，Trait，Concept，TypeClass之间的关系和区别？

首先，我们要知道类型多态的形式：

子类型
针对超类型元素进行操作的子程序、函数等程序元素
如果S是T的子类型，这种关系写作S<:T 意思是在任何需要使用 T 类型对象的环境中，都可以安全地使用 S 类型的对象
特设多态（特定多态）
多态函数有多个不同的实现，依赖于其实参而调用的相应版本的函数。函数重载乃至运算符重载也是特设多态的一种。
参数多态（有限多态）
也就是泛型编程，将不确定的类型作为参数使用，使得该定义对于各种具体类型都适用。
显示要求标注实现
又分为可批量标注和不可批量标注
不要求标注实现
duck type 鸭子类型
structural type system 结构类型及所谓的类型由具体的结构定义而非由定义定义（类型的结构等价原则）
行多态（在编程语言类型理论中，行多态性是一种多态性，它允许人们编写记录字段类型多态的程序（也称为行，因此称为行多态性））
提供默认实现

php 的 trait，oc 的 interface 属于 6
oc 的 protocol 属于 1, 4
go，typescript 的 interface 属于 1, 5
java c# 等的 interface 属于 1, 4, 6
js 的 protocol 提案属于 1, 2, 4
c艹的 concept 属于 2, 3, 5
Haskell 的 typeclass，c# 的 concept 提案属于 2, 3, 4, 4.a
swift 的 protocol, rust 的 trait，scala 的 trait 属于 1, 2, 3, 4, 4.a, 6
作者：头鱼
链接：https://www.zhihu.com/question/314434687/answer/628101937
来源：知乎
著作权归作者所有。商业转载请联系作者获得授权，非商业转载请注明出处。

HomeWork 6

{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-missing-methods #-}{-# LANGUAGE FlexibleInstances #-}module Fibonacci where--------------------------------------------------------------------------------
-- Exercise 1fib :: Integer -> Integer
fib 0 = 0
fib 1 = 1
fib n = fib(n-1) + fib (n-2)fibs1 :: [Integer]
fibs1 = fmap fib [0..]--------------------------------------------------------------------------------
-- Exercise 2fibs3 :: [Integer]
fibs3 = 0:1:zipWith (+) fibs3 (tail fibs3)fibo :: Integer -> Integer -> [Integer]
fibo a b = a : fibo b (a+b)fibs4 :: [Integer]
fibs4 = fibo 0 1--------------------------------------------------------------------------------
-- Eyercise 3
data Stream a = Cons a (Stream a)instance Show a => Show (Stream a) whereshow = show . take 20 . streamToListstreamToList :: Stream a -> [a]
streamToList (Cons y c) = y : streamToList c--------------------------------------------------------------------------------
-- Eyercise 4streamRepeat :: a -> Stream a
streamRepeat a = Cons a (streamRepeat a)streamMap :: (a -> b) -> Stream a -> Stream b
streamMap f (Cons y ys) = Cons (f y) (streamMap f ys)-- 注意此处y是一个seed，cons前面不需要做f运算
streamFromSeed :: (a -> a) -> a -> Stream a
streamFromSeed f y = Cons y (streamFromSeed f (f y))--------------------------------------------------------------------------------
-- Eyercise 5
nats :: Stream Integer
nats = streamFromSeed (+1) 0interleaveStreams :: Stream a -> Stream a -> Stream a
interleaveStreams (Cons y ys) zs = Cons y (interleaveStreams zs ys)-- > 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4
ruler :: Stream Integer
ruler = startRuler 0-- > 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4
-- Eric D.Burgess - http://oeis.org/A001511
startRuler :: Integer -> Stream Integer
startRuler y = interleaveStreams (streamRepeat y) (startRuler (y+1))--------------------------------------------------------------------------------
-- Exercise 6
x :: Stream Integer
x = Cons 0 (Cons 1 (streamRepeat 0))instance Num (Stream Integer) wherefromInteger n = Cons n (streamRepeat 0)negate (Cons y ys) = Cons (-y) (negate ys)-- | A*B = a0*b0+x*(a0*B' + A' * B)(+) (Cons y ys) (Cons z zs) = Cons (y+z) (ys + zs)(*) (Cons y ys) s@(Cons z zs) = Cons (y*z) (streamMap (*y) zs + (ys*s))instance Fractional (Stream Integer) where(/) (Cons y ys) (Cons z zs) = qwhere q = Cons (y `div` z) (streamMap (`div` z) (ys - q * zs))fibs10 :: Stream Integer
fibs10 = x / (1 - x - x * x)--------------------------------------------------------------------------------
-- Exercise 7
data Matrix = Matrix Integer Integer Integer Integer deriving Showinstance Num Matrix where(*) (Matrix a11 a12 a21 a22) (Matrix b11 b12 b21 b22) =(Matrix (a11*b11+a12*b21) (a11*b12+a12*b22)(a21*b11+a22*b21) (a21*b12+a22*b22))fib4 :: Integer -> Integer
fib4 0 = 0
fib4 1 = 1
fib4 n = getA11 (f^(n-1))where f = Matrix 1 1 1 0getA11 :: Matrix -> Integer
getA11 (Matrix a11 _ _ _) = a11

folds-monoids

关于haskell的树的操作…

data Tree a = Empty| Node (Tree a) a (Tree a)deriving (Show, Eq)leaf :: a -> Tree a
leaf x = Node Empty x Empty-- Let’s write a function to compute the size of a tree (i.e. the number of Nodes):treeSize :: Tree a -> Integer
treeSize Empty        = 0
treeSize (Node l _ r) = 1 + treeSize l + treeSize r-- How about the sum of the data in a tree of Integers?treeSum :: Tree Integer -> Integer
treeSum Empty     = 0
treeSum (Node l x r)  = x + treeSum l + treeSum r-- Or the depth of a tree?treeDepth :: Tree a -> Integer
treeDepth Empty        = 0
treeDepth (Node l _ r) = 1 + max (treeDepth l) (treeDepth r)-- Or flattening the elements of the tree into a list?flatten :: Tree a -> [a]
flatten Empty        = []
flatten (Node l x r) = flatten l ++ [x] ++ flatten r

来点generalize…

treeFold :: b -> (b -> a -> b -> b) -> Tree a -> b
treeFold e _ Empty        = e
treeFold e f (Node l x r) = f (treeFold e f l) x (treeFold e f r)treeSize' :: Tree a -> Integer
treeSize' = treeFold 0 (\l _ r -> 1 + l + r)treeSum' :: Tree Integer -> Integer
treeSum' = treeFold 0 (\l x r -> l + x + r)treeDepth' :: Tree a -> Integer
treeDepth' = treeFold 0 (\l _ r -> 1 + max l r)flatten' :: Tree a -> [a]
flatten' = treeFold [] (\l x r -> l ++ [x] ++ r)

这一节课，学了感觉什么也没学
因为他告诉你：monoids是什么？就是一个type class
定义也很简单：

class Monoid m wheremempty  :: mmappend :: m -> m -> mmconcat :: [m] -> mmconcat = foldr mappend mempty(<>) :: Monoid m => m -> m -> m
(<>) = mappend

然后告诉你，ok，你instance一下，就可以用辣：

newtype MyProduct a = MyProduct aderiving (Eq, Ord, Num, Show)getProduct :: MyProduct a -> a
getProduct (MyProduct a) = ainstance Num a => Monoid (MyProduct a) wheremempty  = MyProduct 1mappend = (*)lst :: [Integer]
lst = [1,5,8,23,423,99]prod :: Integer
prod = getProduct . mconcat . map MyProduct $ lst

然后就没了！
怎么，你type class定义在GHC.Base里面就不是type class了是吗？
其实所谓幺半群，需要满足两个条件：
单位元
作用到单位元unit（a）上的f和f（a）一致
其次，作用到非单位元m上的unit，结果还是m本身
结合律
则是这样的条件：(a • b) • c 等于 a • (b • c)

HomeWork 7

JoinList.hs

{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
module JoinList whereimport Data.Monoidimport Buffer
import Editor
import Scrabble
import Sized-- joinlist represent append operations as datadata JoinList m a = Empty| Single m a| Append m (JoinList m a) (JoinList m a)-- instance Buffer (JoinList (score,Size) String) where
--     toString    = unlines . jlToList
--     fromString -------- exercise 1 tag :: Monoid m => JoinList m a -> m
tag (Single m _) = m
tag (Append m _ _) = m
tag _ = mempty(+++) :: Monoid m => JoinList m a -> JoinList m a -> JoinList m a
(+++) a b = Append ((tag a) <> (tag b)) a b-------- exercise 2-------- 课件给出了一个O（1）的实现jlToList :: JoinList m a -> [a]
jlToList Empty = []
jlToList (Single _ a) = [a]
jlToList (Append _ l1 l2) = jlToList l1 ++ jlToList l2(!!?) :: [a] -> Int -> Maybe a
[]     !!? _         = Nothing
_      !!? i | i < 0 = Nothing
(x:xs) !!? 0         = Just x
(x:xs) !!? i         = xs !!? (i-1)-----   2.1indexJ :: (Sized b, Monoid b) => Int -> JoinList b a -> Maybe a
indexJ index (Single _ a)| index == 0 = Just a| otherwise  = Nothing
indexJ index (Append m l1 l2)| index < 0 || index > size0 = Nothing| index < size1              = indexJ index l1| otherwise                  = indexJ (index - size1) l2where size0 = getSize . size $ msize1 = getSize . size . tag $ l1
indexJ _ _ = Nothing--- 2.2
--- @意为asdropJ :: (Sized b, Monoid b) => Int -> JoinList b a -> JoinList b a
dropJ n l1@(Single _ _)| n <= 0 = l1
dropJ n l@(Append m l1 l2)| n >= size0 = Empty| n >= size1 = dropJ (n-size1) l2| n > 0 = dropJ n l1 +++ l2| otherwise  = lwhere size0 = getSize . size $ msize1 = getSize . size . tag $ l1
dropJ _ _ = Empty--- 2.3takeJ :: (Sized b, Monoid b) => Int -> JoinList b a -> JoinList b a
takeJ n l1@(Single _ _)| n > 0 = l1
takeJ n l@(Append m l1 l2)| n >= size0 = l| n >= size1 = l1 +++ takeJ (n-size1) l2| n > 0 = takeJ n l1where size0 = getSize . size $ msize1 = getSize . size . tag $ l1
takeJ _ _ = Empty--- 2.4
scoreLine :: String -> JoinList Score String
scoreLine str = Single (scoreString str) stra = Append (Size 3)(Append (Size 2)(Single (Size 1) "hi")(Single (Size 1) "bye"))(Single (Size 1) "tschau")b = Single (Size 1) "blub"c = Append (Size 2)(Single (Size 1) "hi")(Single (Size 1) "bye")

Scrabble.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}module Scrabble whereimport Data.Char
import Data.Monoidnewtype Score = Score Intderiving (Eq, Read, Show, Ord, Num)instance Semigroup Score whereScore m1 <> Score m2 = Score ((+) m1 m2)instance Monoid Score wheremempty  = Score 0score :: Char -> Score
score c| c' `elem` "aeilnorstu" = Score 1| c' `elem` "dg"         = Score 2| c' `elem` "bcmp"       = Score 3| c' `elem` "fhvwy"      = Score 4| c' `elem` "k"          = Score 5| c' `elem` "jx"         = Score 8| c' `elem` "qz"         = Score 10| otherwise              = Score 0where c' = toLower cscoreString :: String -> Score
scoreString = foldl (\x c -> x + score c) (Score 0)getScore :: Score -> Int
getScore (Score x) = x

IO

介绍了一下IO Type，前面一堆废话,总之是告诉你：IO Type是Recipe Cake不是Cake，必须把它交给运行时系统main :: IO()才能得到Cake
然后是几个库函数：
putStrLn :: String -> IO ()
(>>) :: IO a -> IO b -> IO b用于合并两个IO
(>>=) :: IO a -> (a -> IO b) -> IO b将第一个IO的输出作为第二个IO的输入
然后介绍了Record syntax

HomeWork 8

{-# OPTIONS_GHC -fno-warn-orphans #-}
module Party where
import Employee
import Data.Tree
import Data.Monoid
--- 1.1-- | Adds Employee to the GuestList and update cached Fun score.
glCons :: Employee -> GuestList -> GuestList
-- stupid
-- glCons (Emp {empName = eN,empFun = ef}) (GL lst gf) = GL ((Emp {empName = eN,empFun = ef}):lst) (ef+gf)
glCons emp@(Emp {empFun = ef}) (GL lst gf) = GL (emp:lst) (ef+gf)--- 1.2instance Semigroup GuestList where (GL al af) <> (GL bl bf) = GL (al++bl) (af+bf)instance  Monoid GuestList wheremempty = GL [] 0--- 1.3moreFun :: GuestList -> GuestList -> GuestList
moreFun gl1@(GL gp1 gf1) gl2@(GL gp2 gf2) |gf1>gf2    =   gl1|otherwise  =   gl2treeFold :: (a -> [b] -> b) -> b -> Tree a -> b
treeFold f init (Node {rootLabel = rl, subForest = sf})= f rl (map (treeFold f init) sf)-- | First part of list is with boss.
nextLevel :: Employee -> [(GuestList, GuestList)] -> (GuestList, GuestList)
nextLevel boss bestLists = (maximumS withBossL, maximumS withoutBossL)where withoutBossL   = map fst bestLists-- ^ The new withoutBossList has sub bosses in it.withoutSubBoss = map snd bestListswithBossL      = map (glCons boss) withoutSubBoss-- ^ The new withBossList doesn't have sub bosses in it.maximumS ::(Monoid a, Ord a) => [a] -> a
maximumS [] = mempty
maximumS lst = maximum lstmaxFun :: Tree Employee -> GuestList
maxFun tree = uncurry max reswhere res = treeFold nextLevel (mempty, mempty) tree