[开发工具] [Haskell] CIS 194: Homework 5-8

开发: C++知识库 Java知识库 JavaScript Python PHP知识库人工智能区块链大数据移动开发嵌入式开发工具数据结构与算法开发测试游戏开发网络协议系统运维
教程: HTML教程 CSS教程 JavaScript教程 Go语言教程 JQuery教程 VUE教程 VUE3教程 Bootstrap教程 SQL数据库教程 C语言教程 C++教程 Java教程 Python教程 Python3教程 C#教程
数码: 电脑笔记本显卡显示器固态硬盘硬盘耳机手机 iphone vivo oppo 小米华为单反装机图拉丁

-> 开发工具 -> [Haskell] CIS 194: Homework 5-8 -> 正文阅读

[开发工具][Haskell] CIS 194: Homework 5-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 where

import ExprT ( ExprT(..) )
import Parser ( parseExp )
import StackVM 
import Data.Maybe 
import qualified Data.Map as M

eval :: 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.Mul

class Expr a where
    lit :: Integer -> a
    add :: a -> a -> a
    mul :: a -> a -> a

instance Expr ExprT where
    lit = ExprT.Lit
    add = ExprT.Add
    mul = ExprT.Mul

-- 通过一个实例方法来实现约束
reify :: ExprT -> ExprT 
reify = id

instance Expr Integer where
  lit = id
  add = (+)
  mul = (*)

instance Expr Bool where
  lit x
    | x <= 0    = False
    | otherwise = True
  add = (||)
  mul = (&&)

newtype MinMax = MinMax Integer deriving (Eq, Show)

instance Expr MinMax where
  lit = MinMax
  add (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 where
  lit 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 = testExp

testBool :: Maybe Bool
testBool = testExp

testMM :: Maybe MinMax
testMM = testExp

testSat :: Maybe Mod7
testSat = testExp

instance Expr StackVM.Program where
  lit i = [StackVM.PushI i]
  add a b = a ++ b ++ [StackVM.Add]
  mul a b = a ++ b ++ [StackVM.Mul]

testProg :: Maybe StackVM.Program
testProg = testExp

compile2 :: String -> Either String StackVal
compile2 = stackVM . fromMaybe [] . compile

compile :: String -> Maybe Program
compile = parseExp lit add mul


main :: IO ()
main    =   do
            print(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 1

fib :: Integer -> Integer
fib 0 = 0
fib 1 = 1
fib n = fib(n-1) + fib (n-2)

fibs1 :: [Integer]
fibs1 = fmap fib [0..]


--------------------------------------------------------------------------------
-- Exercise 2

fibs3 :: [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) where
  show = show . take 20 . streamToList

streamToList :: Stream a -> [a]
streamToList (Cons y c) = y : streamToList c


--------------------------------------------------------------------------------
-- Eyercise 4

streamRepeat :: 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) 0


interleaveStreams :: 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) where
    fromInteger 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) = q
        where 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 Show

instance 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 0

getA11 :: 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 where
    mempty  :: m
    mappend :: m -> m -> m

    mconcat :: [m] -> m
    mconcat = foldr mappend mempty

(<>) :: Monoid m => m -> m -> m
(<>) = mappend

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

newtype MyProduct a = MyProduct a
  deriving (Eq, Ord, Num, Show)

getProduct :: MyProduct a -> a
getProduct (MyProduct a) = a

instance Num a => Monoid (MyProduct a) where
  mempty  = MyProduct 1
  mappend = (*)

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 where

import Data.Monoid

import Buffer
import Editor
import Scrabble
import Sized

-- joinlist represent append operations as data

data 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.1

indexJ :: (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) l2
    where size0 = getSize . size $ m
          size1 = getSize . size . tag $ l1
indexJ _ _ = Nothing

--- 2.2 
--- @意为as

dropJ :: (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  = l
    where size0 = getSize . size $ m
          size1 = getSize . size . tag $ l1
dropJ _ _ = Empty

--- 2.3

takeJ :: (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 l1
    where size0 = getSize . size $ m
          size1 = getSize . size . tag $ l1
takeJ _ _ = Empty



--- 2.4
scoreLine :: String -> JoinList Score String
scoreLine str = Single (scoreString str) str


a = 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 where

import Data.Char
import Data.Monoid

newtype Score = Score Int
  deriving (Eq, Read, Show, Ord, Num)

instance Semigroup Score where
  Score m1 <> Score m2 = Score ((+) m1 m2)

instance Monoid Score where
  mempty  = Score 0

score :: 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 0
    where c' = toLower c

scoreString :: 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 a -> (a -> IO b) -> IO b
然后介绍了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.2

instance Semigroup GuestList where 
    (GL al af) <> (GL bl bf) = GL (al++bl) (af+bf)

instance  Monoid GuestList where
    mempty = GL [] 0

--- 1.3

moreFun :: GuestList -> GuestList -> GuestList
moreFun gl1@(GL gp1 gf1) gl2@(GL gp2 gf2) 
    |gf1>gf2    =   gl1
    |otherwise  =   gl2

treeFold :: (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 bestLists
        withBossL      = 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 lst

maxFun :: Tree Employee -> GuestList
maxFun tree = uncurry max res
  where res = treeFold nextLevel (mempty, mempty) tree