[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之间的关系和区别？

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

1. 子类型
   针对超类型元素进行操作的子程序、函数等程序元素
   如果S是T的子类型，这种关系写作S<:T 意思是在任何需要使用 T 类型对象的环境中，都可以安全地使用 S 类型的对象

2. 特设多态（特定多态）
   多态函数有多个不同的实现，依赖于其实参而调用的相应版本的函数。函数重载乃至运算符重载也是特设多态的一种。

3. 参数多态（有限多态）
   也就是泛型编程，将不确定的类型作为参数使用，使得该定义对于各种具体类型都适用。

4. 显示要求标注实现
   又分为可批量标注和不可批量标注

5. 不要求标注实现
   duck type 鸭子类型
   structural type system 结构类型 及所谓的类型由具体的结构定义而非由定义定义（类型的结构等价原则）
   行多态（在编程语言类型理论中，行多态性是一种多态性，它允许人们编写记录字段类型多态的程序（也称为行，因此称为行多态性））

6. 提供默认实现

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
(>>=) :: 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.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