From ae7d8db3dbcfd2d9b33504015205f4ffaf9ca50d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Depreeuw?= Date: Tue, 31 Oct 2017 22:49:04 +0100 Subject: [PATCH] Complete chapter 15 --- 15-monoid-semigroup/15.10-optional-monoid.md | 2 + .../15.12-maybe-another-monoid.md | 2 + .../15.15-chapter-exercises.md | 2 + 15-monoid-semigroup/orphan-instance/Listy.hi | Bin 0 -> 1401 bytes 15-monoid-semigroup/orphan-instance/Listy.hs | 8 + 15-monoid-semigroup/orphan-instance/Listy.o | Bin 0 -> 12192 bytes .../orphan-instance/ListyInstances.hi | Bin 0 -> 958 bytes .../orphan-instance/ListyInstances.hs | 9 + .../orphan-instance/ListyInstances.o | Bin 0 -> 3592 bytes 15-monoid-semigroup/src/First.hs | 41 +++ 15-monoid-semigroup/src/Optional.hs | 9 + 15-monoid-semigroup/src/madness.hs | 22 ++ 15-monoid-semigroup/src/semmon.hs | 341 ++++++++++++++++++ 13 files changed, 436 insertions(+) create mode 100644 15-monoid-semigroup/15.10-optional-monoid.md create mode 100644 15-monoid-semigroup/15.12-maybe-another-monoid.md create mode 100644 15-monoid-semigroup/15.15-chapter-exercises.md create mode 100644 15-monoid-semigroup/orphan-instance/Listy.hi create mode 100644 15-monoid-semigroup/orphan-instance/Listy.hs create mode 100644 15-monoid-semigroup/orphan-instance/Listy.o create mode 100644 15-monoid-semigroup/orphan-instance/ListyInstances.hi create mode 100644 15-monoid-semigroup/orphan-instance/ListyInstances.hs create mode 100644 15-monoid-semigroup/orphan-instance/ListyInstances.o create mode 100644 15-monoid-semigroup/src/First.hs create mode 100644 15-monoid-semigroup/src/Optional.hs create mode 100644 15-monoid-semigroup/src/madness.hs create mode 100644 15-monoid-semigroup/src/semmon.hs diff --git a/15-monoid-semigroup/15.10-optional-monoid.md b/15-monoid-semigroup/15.10-optional-monoid.md new file mode 100644 index 0000000..2b1e60a --- /dev/null +++ b/15-monoid-semigroup/15.10-optional-monoid.md @@ -0,0 +1,2 @@ +# Exercise: Optional Monoid +see src/Optional.hs diff --git a/15-monoid-semigroup/15.12-maybe-another-monoid.md b/15-monoid-semigroup/15.12-maybe-another-monoid.md new file mode 100644 index 0000000..4216337 --- /dev/null +++ b/15-monoid-semigroup/15.12-maybe-another-monoid.md @@ -0,0 +1,2 @@ +# Exercise: Maybe Another Monoid +see src/First.hs \ No newline at end of file diff --git a/15-monoid-semigroup/15.15-chapter-exercises.md b/15-monoid-semigroup/15.15-chapter-exercises.md new file mode 100644 index 0000000..45d2cdb --- /dev/null +++ b/15-monoid-semigroup/15.15-chapter-exercises.md @@ -0,0 +1,2 @@ +# Chapter Exercises +see src/sem.hs \ No newline at end of file diff --git a/15-monoid-semigroup/orphan-instance/Listy.hi b/15-monoid-semigroup/orphan-instance/Listy.hi new file mode 100644 index 0000000000000000000000000000000000000000..f4a261f0b474a30508092fc80b1a5c56376f4394 GIT binary patch literal 1401 zcmah}Ur19?7(e%J%gt#zXQg14IaCOzWPy1i2YrEp z&*NVQx4YKwMQ`5Oe*h~Ww1hNxr766?25AuuKAt*acj?I{g;>=$5I>bzBe7}3rW3mx zA?g_9ugJbG%(Km3cj!}#<^~L|o-rU~CS$aCbINl2{^aC!(MfSr06Qnp-@puhyO&6@P5kaV4kb zWwaS62Bn;jri3PsbDR_BUBhd|v-69-y^ zhl0^G+DR@OBL0yBfik7X{}b4=qkx?G%Nw{!S#`Ej#@Tdo6n!Xt$yWzYHJ+7fwOr;yBz$3^&Db{M-nR&uGpf z?&Q#KclDpeeD7{_V66#-0-T4DxK35xc!rS}tDTeDS%E}n$&e!w^hms5#YaU|M+tWGL7r3pQk3A! z-67U$4@Z~)7b_wSvT(9NR^U7$kI zg1`nM-dN&5+X9Rzvg!$g#b*yE_7Q)+%1F2Pl&lk3qs0gEiIBk}d5RMOJq8ke93Z%P IZzRC}1*~NP0{{R3 literal 0 HcmV?d00001 diff --git a/15-monoid-semigroup/orphan-instance/Listy.hs b/15-monoid-semigroup/orphan-instance/Listy.hs new file mode 100644 index 0000000..8cb8ebe --- /dev/null +++ b/15-monoid-semigroup/orphan-instance/Listy.hs @@ -0,0 +1,8 @@ +module Listy where + +newtype Listy a = Listy [a] deriving (Eq, Show) + +instance Monoid (Listy a) where + mempty = Listy [] + mappend (Listy l) (Listy l') = + Listy $ mappend l l' \ No newline at end of file diff --git a/15-monoid-semigroup/orphan-instance/Listy.o b/15-monoid-semigroup/orphan-instance/Listy.o new file mode 100644 index 0000000000000000000000000000000000000000..60f1201ac0fb58871a85c2f1aea15963228dd31f GIT binary patch literal 12192 zcmeI2Z*1LF8OKj|Cl(Y|LNJYBb|(`{22DE#bOYgzyN-KVJIcC$?2qkTd%Kpcw|Dp6 zvaZ3fI2U`v7V8_S(HAv}E6bAEqspJ?ycxTLPmNU1aTno3WoG0|Hq?U-%G%r)lf04}4} zlAvb{`Vl%3C)-OMYs{{#YwbL}Nt7u)9(#nE!&*xAyX0MFsi`h|3P+42~g zw$#!K|K9rUz_R5VSV&c$pf=l`hu!-U$KI~*D3%h%*Am5Zt+USbu@~wS$7c&s@?{>A z6UFwj^UgX!F3nq)7H%Sc=CwbPn`>zn+7zF)v!bGEZ#nT~ydhb9v04{24NOXou7g=B zH2)I(T;tDAJh{7(bP&E|<<7Ow*}Ay5MDAU(?m6dPiPM5F7K#$I6 zJbCPehR(a6-bwKAD(!Ug+=i89%uk-A#-i|(=Z;U%9O#272%_kGe3bf<&jGU2B6c=w zJ4mig4%xG*NftM(EG3J3R?frnCFRGSmE}b7#boid>Xl$uTF9J>TJ576>ucBNcHf0y zGrQ#}w$G6S?=H1Gh!I8hvFN{w*m623%r*)0UJC6BxPJjN5Y}9>SfJP_tP9{aYn{b4 zE0ZTFS{0hz4IEY*&84u))#t}Yh>C4!hd)oyLH3)({wmm*BWOCwtj*>ekXzN_QZl>fNBeAxyr%ihs8{-yx{IY zd1;iqEJws@4^u}j6M6$T(zGBp(SOHBViK{-gG4t;?0<44nrFIS=AE4`$&Z&io6wKFk7L5=2-0J?=(k zaUc z*O_|0zCF(4KM2wDn-KnL2(Kf(wc=V4!XFIb2SWG>;)tu{#r3r1b*70=rG6fNE=12C zL-jhj9L~3HO9rinU8}EkN4_Ut$Qc^k91K1bw6+AT&Y;yD zw05`_xseOl_JHLBwk=?}z^{Dk_7;cxS|4c(1oB#7b$|;2CSwJex9hGzU{ni?2KX_J z9}DKi1A)U@;IPBw+CCOt-LgMmYXioS^{sB%Vv|QcjRks$ZWnq)(biU>A9Z3&6fqKHWo)*yBU@qcz??&^eMB8S3BFxodMUiKg_VvOQVe1KynBR5qK= z^t%YG)`}X}mEGq}jPHs&W8_n+Fx2NX>>unKAI|26hMikmk7U#No+@`T>BI5$8x6eL zH`p_p?e7`LrH0dPx@Tj&zkhhRZzR)~sw}gF(=(9D7p$649o>T?hY=0xDj%RDxp`|x za#MSdriy7hEl+duUAc7axZ>S~+)!qJ&uAu_>N~)_@xeeDJDG7#)=1FG%Z?W)Z4s-R zR?sbPuy(bik#Q&)na+srsuN4B7jm5={i6rdVHt25SVo_jfr7qq&;Qy!9Ep>U zwG~u{uWz~ZxMuF8V~#!_qsV(Io>+URKMmn?0$|8xefnT@%y=rN}e;suDpL-%@d)2gOdLgbLekZ z+`X^4JZO3MUbZ+t2bKPfq~{Fx<+(xpk!KS3-n3Z1dv7xKO#;7HNcpkyGa-=b3(S4} z?!9KQe!P#MAP<;2><$jyya_hmwn7QCFb8_4!fJgDAnhg zqr#qS;;}y~J=*TON>3-tqKeS-JPP8~`+1q-dcC5|#jfn1?Mfc5%lDOx$L0IV7nvh2 z_f3f!RHi-sjvDhjPmgSL`EV)g6=S)jOWjQ9hp&UIsDZioA7g$8bLi1|+v&;6-ugm_ z{In^T=JdiHjm5qq?pI$yHU5|TbxS!_i^UPPnY5o%q2fE z_N>ygLCHU_IM!XhGrggBx03&h;@DTgziiNZ1d7;|ysc&~d6?$;apv%UtDWio>{J}O zCU~sZ(=TxySNe5ar#$%>>v=`VBVPGV_7-#avyEkK#owW1A5QUDz533D^S77z9n2+O z`F^%e>DkV*sM3lf-cvl5_4LdBpYnJw%b#T~cIErouatgm_wS0s?s?WDAGBm0v&@_7 zT|>C|)5#omb^iA%jy%ivwls6(Q~NW;+}HoS(xdgiq&W1;_qmrt^w;xyxajYtIVkIx zOWx#rVW-FCyI`;4yPXRA_e;zX*CUEQz-`#QhYoojct!EJ;x{80Dv;Owh~m&Gdd@1I zRQxkgK*iT{T5&w{h@M8i?qYbe;$K!=%a{2)hP?JCq0T$)|9l9K^FH+b>{Wb+^5>%B zRr(djGn>SfQTs~EPb#kUzoxjBmrtVbQ|qU$Em#H|QQND0n-M<7T*krgWrnJW+u--n zff}X7Rkjb?I8fSL74QW2r53wW%mk|_kr^sm)`*{c|2P0KuK}=4F{;Kxcd!D0cyfeJZG{R{@uiJE#Ck^Dk9(Dy1{oh z@Xs?t6;<+BlXrNm$>UdYU%uC)tL?^=Jp62AJqg8onW5@Zd@uF6Yj!FQf7WtezWbxA z?H*O~up6ZVMV{v|+zY^EQpsz(Q;Nf`T&H9nhV}cGtOL00Wyngt!S4s)BKZKv`;n9= zH^AEkQr)C@LUDZ_J*aq_lHa6wOmY3ZEjnRWKlgSidBioy{hc14;C`>ir?@ZkpkH)i zD9hvE`gv(gasAwKRB?Tu75mTwKTomTq>=|e&wcR=^7_7Jn)6473#oln7jmv1lvXZ% zFx6a0j}=U_ZT6=MDbu_!pQrwa>jWGUL``#Mq>yfYVDq-y=*_?HfNAa<86Hk&3hc(e zT}4R)V&L0QpfAR)6MX-cfqH3heFN1?>4nLvgROC5A<~KTQR#6T6eA#76 z@3(As27{`|d_gx;qn7;{3{a8#H|)cP%oqEu%zXP3m{6m5?$~!!FzgLoWInqQ42gXK zacb0x|1{g57D2B4`M6isivPkbZo(Wp40U)Ekogin&Lux4%qhY#QtkPtS2>9x5#-vR F|1Tf+sw4ma literal 0 HcmV?d00001 diff --git a/15-monoid-semigroup/orphan-instance/ListyInstances.hi b/15-monoid-semigroup/orphan-instance/ListyInstances.hi new file mode 100644 index 0000000000000000000000000000000000000000..b99c84234488c417d02b3b7820173f20deee8abd GIT binary patch literal 958 zcmZSlbuNVg3Rr-&1rQrRu@R7Fasgr`AOi##86I3ae(l3D-BY)(Rjho+nQ}VI>Vwvq z-j{CYvb8y1PrvXjEl2V3@)y(omcO6e(9|z0&j`|X7DO^JFat?u5EEn%11nGj$OmFJ zD9z3RWx!}oD4z>Tb3aJUY7C zXvrIo?rB#TW8#vZ9D29Yr1n!*>8zd!#i>v> zM|wuGZb4CIE|kxmnOBmUo?4`vo?8G@;_l(B=Y-J03F5ouomF6Xv|#koDq{5Qz7;aPwbjBYvPD_IEQm!9m;1y;M{`YeAE~=PmhzAnuF2u zx9H&9ZVaU!G)B%~YwYa)F#H3-H~6!>AB^XY)zFkulo$K^>+{asvA4)cQ%{0Tbw^nD z4QKc7a&s_r2ERIk+Y7f;>D}+k&WE?MD)chKU}w-6tL|hI(9%e@w0|7>ksex!|D}n0 zMv1&IM%@h4Z2Rpv&AiwTQY3eg6{lWZvghr^yZFJfRrrJ;=PssmSmNGk05kQB9rQmU zJxiiW5wDT1NPR!eChA3LTH=ujl9nxhOX50lem0ln+!79PRt;&C#7zQCUI1;0`?Q%d z-;wGdUzgkxT_YkO|FXg5&4LQtr@m~7gZssGOFW>v<+dfXmz3!HppO>ZmrsG4*9=3x zp26?T;J*XM{8iAp9EKZQl>gNk{M{LReFl$b@K0v&&t~vDz_I^5y?LvV|8OKkA_&+>%0BFDs03=UcVp2ZM8O?ev(h} zJfV@HzEM|Ip-V3deU<8J*WZcyNf@dAE^haO)Sc=p4zAUg&kAg>)pfV}ZMTznQBc_B zPP-jNelPaDEN_GN<#xO@6NU9ICTo!K!c=1i_LwEBz4q2-kS8uoMLzl#rym?VXYjfI zZC{BxhlG4HAJ<$@k^La(Cp6CI4!+5JX5q3rR}{niL&|>x7eTo0nE00pOa2Vl{}BI< zIM#iZY*aszjdh=b0gu0wpGhNsj%-vbWMf_Y=5qdDH2%EC3Cp~gyGnr12xK_;9OQLm z6&Nfh$w2-z4Ady|O369)gac(sshm4BXN~bVZW8a3M)m^PsQP3h$7{#J{hIza$btRK zG~d&Bm26ZWla2n^dq{Kci}^NjR><||itDgH`{~zNzmFAiK!3dNx!CD;lzA;-!|9}S zm#rk&^z1CSo(Wr;Z7=hL-AYrK_tYfk=mAvNaW4z(m9dM}J(?WP*Y9QG=0BQ~6!!(J>%#HO zPJmHVze|qiwE9?sD_(75&w@LUDNg@s@Br@BbVyb59sjHaCP2#Pq#FY#tXi;duR>$7PP!by2Ab v!3tfNhamPb7-s*tP4n6T67%%e`B5V|*F_(cqcDo%EA*F;&lBkkKW6;D8|sB2 literal 0 HcmV?d00001 diff --git a/15-monoid-semigroup/src/First.hs b/15-monoid-semigroup/src/First.hs new file mode 100644 index 0000000..99efbef --- /dev/null +++ b/15-monoid-semigroup/src/First.hs @@ -0,0 +1,41 @@ +module First where + +import Optional +import Data.Monoid +import Test.QuickCheck + +monoidAssoc :: (Eq m, Monoid m) => m -> m -> m -> Bool +monoidAssoc a b c = (a <> (b <> c)) == ((a <> b) <> c) + +monoidLeftIdentity :: (Eq m, Monoid m) => m -> Bool +monoidLeftIdentity a = (mempty <> a) == a + +monoidRightIdentity :: (Eq m, Monoid m) => m -> Bool +monoidRightIdentity a = (a <> mempty) == a + + +newtype First' a = First' { getFirst' :: Optional a } deriving (Eq, Show) + +instance Monoid (First' a) where + mempty = First' Nada + mappend (First' Nada) a = a + mappend a _ = a + +instance Arbitrary a => Arbitrary (First' a) where + arbitrary = do + a <- arbitrary + frequency [(1, return $ First' Nada), (1, return $ First' (Only a))] + +firstMappend :: First' a -> First' a -> First' a +firstMappend = mappend + +type FirstMappend = First' String -> First' String -> First' String -> Bool +type FstId = First' String -> Bool + +main :: IO () +main = do + quickCheck (monoidAssoc :: FirstMappend) + quickCheck (monoidLeftIdentity :: FstId) + quickCheck (monoidRightIdentity :: FstId) + + diff --git a/15-monoid-semigroup/src/Optional.hs b/15-monoid-semigroup/src/Optional.hs new file mode 100644 index 0000000..dafc834 --- /dev/null +++ b/15-monoid-semigroup/src/Optional.hs @@ -0,0 +1,9 @@ +module Optional where + +data Optional a = Nada | Only a deriving (Eq, Show) + +instance Monoid a => Monoid (Optional a) where + mempty = Nada + mappend Nada a = a + mappend a Nada = a + mappend (Only a) (Only b) = Only $ mappend a b \ No newline at end of file diff --git a/15-monoid-semigroup/src/madness.hs b/15-monoid-semigroup/src/madness.hs new file mode 100644 index 0000000..fc32e3c --- /dev/null +++ b/15-monoid-semigroup/src/madness.hs @@ -0,0 +1,22 @@ +module Madness where + +import Data.Monoid + +type Verb = String +type Adjective = String +type Adverb = String +type Noun = String +type Exclamation = String + +madlibbin' :: Exclamation -> Adverb -> Noun -> Adjective -> String +madlibbin' e adv noun adj = + e <> "! he said " <> + adv <> " as he jumped into his car " <> + noun <> " and drove off with his " <> + adj <> " wife." + +madlibbinBetter' :: Exclamation -> Adverb -> Noun -> Adjective -> String +madlibbinBetter' e adv noun adj = + mconcat [e, "! he said ", adv, " as he jumped into his car ", + noun, " and drove off with his ", adj, " wife."] + diff --git a/15-monoid-semigroup/src/semmon.hs b/15-monoid-semigroup/src/semmon.hs new file mode 100644 index 0000000..677a16e --- /dev/null +++ b/15-monoid-semigroup/src/semmon.hs @@ -0,0 +1,341 @@ +module SemMon where + +import Data.Semigroup (Semigroup, (<>), Sum, Product) +import Data.Monoid (Monoid) +import Test.QuickCheck + +-- Note: +-- So as to not have to rewrite all the mappend rules, all Monoid instance, +-- will require the type to also be a Semigroup. + +-- Semigroup +semigroupAssoc :: (Eq m, Semigroup m) => m -> m -> m -> Bool +semigroupAssoc a b c = (a <> (b <> c)) == ((a <> b) <> c) +-- Monoid +monoidAssoc :: (Eq m, Monoid m) => m -> m -> m -> Bool +monoidAssoc a b c = + (a `mappend` (b `mappend` c)) == ((a `mappend` b) `mappend` c) + +monoidLeftIdent :: (Eq m, Monoid m) => m -> Bool +monoidLeftIdent a = (mappend mempty a) == a + +monoidRightIdent :: (Eq m, Monoid m) => m -> Bool +monoidRightIdent a = (mappend a mempty) == a + +-- 1 +-- Semigroup +data Trivial = Trivial deriving (Eq, Show) +instance Semigroup Trivial where + _ <> _ = Trivial +instance Arbitrary Trivial where + arbitrary = return Trivial +type TrivAssoc = Trivial -> Trivial -> Trivial -> Bool +-- Monoid +instance Monoid Trivial where + mempty = Trivial + mappend = (<>) +type TrivId = Trivial -> Bool + +-- 2 +-- Semigroup +newtype Identity a = Identity a deriving (Eq, Show) +instance Semigroup a => Semigroup (Identity a) where + (Identity a) <> (Identity a') = Identity $ a <> a' +instance Arbitrary a => Arbitrary (Identity a) where + arbitrary = do + a <- arbitrary + return $ Identity a +type IdentityAssoc = Identity String -> + Identity String -> + Identity String -> + Bool +-- Monoid +instance (Semigroup a, Monoid a) => Monoid (Identity a) where + mempty = Identity mempty + mappend = (<>) +type IdentityId = Identity String -> Bool + +-- 3 +-- Semigroup +data Two a b = Two a b deriving (Eq, Show) +instance (Semigroup a, Semigroup b) => Semigroup (Two a b) where + (Two a b) <> (Two a' b') = Two (a <> a') (b <> b') +instance (Arbitrary a, Arbitrary b) => Arbitrary (Two a b) where + arbitrary = do + a <- arbitrary + b <- arbitrary + return $ Two a b +type TwoAssoc = Two (Sum Int) (Product Int) -> + Two (Sum Int) (Product Int) -> + Two (Sum Int) (Product Int) -> + Bool +-- Monoid +instance (Semigroup a, Semigroup b, Monoid a, Monoid b) + => Monoid (Two a b) where + mempty = Two mempty mempty + mappend = (<>) +type TwoId = Two (Sum Int) (Product Int) -> Bool + +-- 4 +-- Semigroup +data Three a b c = Three a b c deriving (Eq, Show) +instance (Semigroup a, Semigroup b, Semigroup c) + => Semigroup (Three a b c) where + (Three a b c) <> (Three a' b' c') = + Three (a <> a') (b <> b') (c <> c') +instance (Arbitrary a, Arbitrary b, Arbitrary c) + => Arbitrary (Three a b c) where + arbitrary = do + a <- arbitrary + b <- arbitrary + c <- arbitrary + return $ Three a b c +type ThreeAssoc = Three (Sum Int) (Product Int) String -> + Three (Sum Int) (Product Int) String -> + Three (Sum Int) (Product Int) String -> + Bool +-- Monoid +instance (Semigroup a, Semigroup b, Semigroup c, Monoid a, Monoid b, Monoid c) + => Monoid (Three a b c) where + mempty = Three mempty mempty mempty + mappend = (<>) +type ThreeId = Three (Sum Int) (Product Int) String -> Bool + +-- 5 +-- Semigroup +data Four a b c d = Four a b c d deriving (Eq, Show) +instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d) + => Semigroup (Four a b c d) where + (Four a b c d) <> (Four a' b' c' d') = + Four (a <> a') (b <> b') (c <> c') (d <> d') +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) + => Arbitrary (Four a b c d) where + arbitrary = do + a <- arbitrary + b <- arbitrary + c <- arbitrary + d <- arbitrary + return $ Four a b c d +type FourAssoc = Four (Sum Int) (Product Int) String Ordering -> + Four (Sum Int) (Product Int) String Ordering -> + Four (Sum Int) (Product Int) String Ordering -> + Bool +-- Monoid +instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, + Monoid a, Monoid b, Monoid c, Monoid d) => + Monoid (Four a b c d) where + mempty = Four mempty mempty mempty mempty + mappend = (<>) +type FourId = Four (Sum Int) (Product Int) String Ordering -> Bool + +-- 6 +-- Semigroup +newtype BoolConj = BoolConj Bool deriving (Eq, Show) +instance Semigroup BoolConj where + (BoolConj True) <> (BoolConj True) = BoolConj True + _ <> _ = BoolConj False +instance Arbitrary BoolConj where + arbitrary = do + b <- arbitrary + return $ BoolConj b +type BoolConjAssoc = BoolConj -> BoolConj -> BoolConj -> Bool +-- Monoid +instance Monoid BoolConj where + mempty = BoolConj True + mappend = (<>) +type BoolConjId = BoolConj -> Bool + +-- 7 +-- Semigroup +newtype BoolDisj = BoolDisj Bool deriving (Eq, Show) +instance Semigroup BoolDisj where + (BoolDisj False) <> (BoolDisj False) = BoolDisj False + _ <> _ = BoolDisj True +instance Arbitrary BoolDisj where + arbitrary = do + b <- arbitrary + return $ BoolDisj b +type BoolDisjAssoc = BoolDisj -> BoolDisj -> BoolDisj -> Bool +-- Monoid +instance Monoid BoolDisj where + mempty = BoolDisj False + mappend = (<>) +type BoolDisjId = BoolDisj -> Bool + +-- 8 +-- Semigroup +data Or a b = Fst a | Snd b deriving (Eq, Show) +instance Semigroup (Or a b) where + Snd a <> _ = Snd a + _ <> Snd a = Snd a + _ <> a = a +instance (Arbitrary a, Arbitrary b) => Arbitrary (Or a b) where + arbitrary = do + a <- arbitrary + b <- arbitrary + elements [Fst a, Snd b] +type OrAssoc = Or Int Float -> Or Int Float -> Or Int Float -> Bool +-- Monoid +-- not possible as there is no identity possible. + +-- 9 +-- Semigroup +newtype Combine a b = Combine { unCombine :: (a -> b)} +-- instance Semigroup b => Semigroup (a -> b) where +-- f <> g = \a -> f a <> g a +-- In other words, f and g are applied to the argument +-- and the results are mappended. +instance Semigroup b => Semigroup (Combine a b) where + f <> g = Combine $ (unCombine f) <> (unCombine g) +instance (CoArbitrary a, Arbitrary b) => Arbitrary (Combine a b) where + arbitrary = do + f <- arbitrary + return $ Combine f +instance Show (Combine a b) where + show _ = "Combine a b" -- needed for QuickCheck, no idea what to really + -- do about this. +semigroupAssoc' :: Int -> -- the input for the function + Combine Int String -> + Combine Int String -> + Combine Int String -> + Bool +semigroupAssoc' i f g h = + (unCombine (f <> (g <> h))) i == (unCombine ((f <> g) <> h)) i +-- Monoid +instance (Semigroup b, Monoid b) => Monoid (Combine a b) where + mempty = Combine $ \_ -> mempty -- f a <> mempty a = f a + -- mempty a <> f a = f a + -- f a = b, so mempty is of type b + mappend = (<>) +monoidAssoc' :: Int -> -- the input for the function + Combine Int String -> + Combine Int String -> + Combine Int String -> + Bool +monoidAssoc' i f g h = + (unCombine (f `mappend` (g `mappend` h))) i + == (unCombine ((f `mappend` g) `mappend` h)) i + +monoidLeftIdent' :: Int -> Combine Int String -> Bool +monoidLeftIdent' i f = (unCombine (mappend mempty f)) i == (unCombine f) i + +monoidRightIdent' :: Int -> Combine Int String -> Bool +monoidRightIdent' i f = (unCombine (mappend f mempty)) i == (unCombine f) i + +-- 10 +-- Semigroup +newtype Comp a = Comp { unComp :: (a -> a) } +instance Semigroup (Comp a) where + f <> g = Comp $ unComp f . unComp g +instance (CoArbitrary a, Arbitrary a) => Arbitrary (Comp a) where + arbitrary = do + f <- arbitrary + return $ Comp f +instance Show (Comp a) where + show _ = "Comp a" -- needed for QuickCheck, no idea what to really + -- do about this. +semigroupAssoc'' :: Int -> -- the input for the function + Comp Int -> + Comp Int -> + Comp Int -> + Bool +semigroupAssoc'' i f g h = + (unComp (f <> (g <> h))) i == (unComp ((f <> g) <> h)) i +-- Monoid +instance Monoid (Comp a) where + mempty = Comp id + mappend= (<>) +monoidAssoc'' :: Int -> + Comp Int -> + Comp Int -> + Comp Int -> + Bool +monoidAssoc'' i f g h = + (unComp (f `mappend` (g `mappend` h))) i + == (unComp ((f `mappend` g) `mappend` h)) i + +monoidLeftIdent'' :: Int -> Comp Int -> Bool +monoidLeftIdent'' i f = (unComp (mappend mempty f)) i == (unComp f) i + +monoidRightIdent'' :: Int -> Comp Int -> Bool +monoidRightIdent'' i f = (unComp (mappend f mempty)) i == (unComp f) i + +-- 8 +-- Monoid +newtype Mem s a = Mem { runMem :: s -> (a,s) } +instance Monoid a => Monoid (Mem s a) where + mempty = Mem $ \s -> (mempty, s) + mappend f g = Mem $ \s -> + let (a, s') = runMem g $ s + (a', s'') = runMem f $ s' + in (mappend a a', s'') +instance (CoArbitrary s, Arbitrary a, Arbitrary s) => Arbitrary (Mem s a) where + arbitrary = do + f <- arbitrary + return $ Mem f +instance Show (Mem s a) where + show _ = "Mem s a" +monoidAssoc''' :: Int -> + Mem Int String -> + Mem Int String -> + Mem Int String -> + Bool +monoidAssoc''' i f g h = + (runMem (f `mappend` (g `mappend` h))) i + == (runMem ((f `mappend` g) `mappend` h)) i + +monoidLeftIdent''' :: Int -> Mem Int String -> Bool +monoidLeftIdent''' i f = (runMem (mappend mempty f)) i == (runMem f) i + +monoidRightIdent''' :: Int -> Mem Int String -> Bool +monoidRightIdent''' i f = (runMem (mappend f mempty)) i == (runMem f) i + +main :: IO () +main = do + putStrLn "Semigroup tests" + quickCheck (semigroupAssoc :: TrivAssoc) + quickCheck (semigroupAssoc :: IdentityAssoc) + quickCheck (semigroupAssoc :: TwoAssoc) + quickCheck (semigroupAssoc :: ThreeAssoc) + quickCheck (semigroupAssoc :: FourAssoc) + quickCheck (semigroupAssoc :: BoolConjAssoc) + quickCheck (semigroupAssoc :: BoolDisjAssoc) + quickCheck (semigroupAssoc :: OrAssoc) + quickCheck semigroupAssoc' + quickCheck semigroupAssoc'' + + putStrLn "Monoid tests - Associativity" -- actually same as semigroup + quickCheck (monoidAssoc :: TrivAssoc) + quickCheck (monoidAssoc :: IdentityAssoc) + quickCheck (monoidAssoc :: TwoAssoc) + quickCheck (monoidAssoc :: ThreeAssoc) + quickCheck (monoidAssoc :: FourAssoc) + quickCheck (monoidAssoc :: BoolConjAssoc) + quickCheck (monoidAssoc :: BoolDisjAssoc) + quickCheck monoidAssoc' + quickCheck monoidAssoc'' + quickCheck monoidAssoc''' + + putStrLn "Monoid tests - Left Identity" + quickCheck (monoidLeftIdent :: TrivId) + quickCheck (monoidLeftIdent :: IdentityId) + quickCheck (monoidLeftIdent :: TwoId) + quickCheck (monoidLeftIdent :: ThreeId) + quickCheck (monoidLeftIdent :: FourId) + quickCheck (monoidLeftIdent :: BoolConjId) + quickCheck (monoidLeftIdent :: BoolDisjId) + quickCheck monoidLeftIdent' + quickCheck monoidLeftIdent'' + quickCheck monoidLeftIdent''' + + putStrLn "Monoid tests - Right Identity" + quickCheck (monoidRightIdent :: TrivId) + quickCheck (monoidRightIdent :: IdentityId) + quickCheck (monoidRightIdent :: TwoId) + quickCheck (monoidRightIdent :: ThreeId) + quickCheck (monoidRightIdent :: FourId) + quickCheck (monoidRightIdent :: BoolConjId) + quickCheck (monoidRightIdent :: BoolDisjId) + quickCheck monoidRightIdent' + quickCheck monoidRightIdent'' + quickCheck monoidRightIdent''' \ No newline at end of file