freemonad: Update the Free monad notebook

Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>
This commit is contained in:
Sanchayan Maity 2020-08-08 19:01:31 +05:30
parent 91050d615a
commit cce60e0790
1 changed files with 201 additions and 32 deletions

View File

@ -2,7 +2,7 @@
"cells": [
{
"cell_type": "code",
"execution_count": 4,
"execution_count": 3,
"metadata": {},
"outputs": [
{
@ -415,12 +415,17 @@
"\n",
":t (Fix (Output 'A' (Fix Done)))\n",
"\n",
":t (Fix (Bell (Fix (Output 'A' (Fix Done)))))"
":t (Fix (Bell (Fix (Output 'A' (Fix Done)))))\n",
"\n",
"-- cosine x = x\n",
"-- x = 0.7...\n",
"\n",
"-- f x = x"
]
},
{
"cell_type": "code",
"execution_count": 13,
"execution_count": 10,
"metadata": {},
"outputs": [
{
@ -432,6 +437,108 @@
"metadata": {},
"output_type": "display_data"
},
{
"data": {
"text/plain": [
"120"
]
},
"metadata": {},
"output_type": "display_data"
},
{
"data": {
"text/html": [
"<style>/* Styles used for the Hoogle display in the pager */\n",
".hoogle-doc {\n",
"display: block;\n",
"padding-bottom: 1.3em;\n",
"padding-left: 0.4em;\n",
"}\n",
".hoogle-code {\n",
"display: block;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"}\n",
".hoogle-text {\n",
"display: block;\n",
"}\n",
".hoogle-name {\n",
"color: green;\n",
"font-weight: bold;\n",
"}\n",
".hoogle-head {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-sub {\n",
"display: block;\n",
"margin-left: 0.4em;\n",
"}\n",
".hoogle-package {\n",
"font-weight: bold;\n",
"font-style: italic;\n",
"}\n",
".hoogle-module {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-class {\n",
"font-weight: bold;\n",
"}\n",
".get-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"display: block;\n",
"white-space: pre-wrap;\n",
"}\n",
".show-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"margin-left: 1em;\n",
"}\n",
".mono {\n",
"font-family: monospace;\n",
"display: block;\n",
"}\n",
".err-msg {\n",
"color: red;\n",
"font-style: italic;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"display: block;\n",
"}\n",
"#unshowable {\n",
"color: red;\n",
"font-weight: bold;\n",
"}\n",
".err-msg.in.collapse {\n",
"padding-top: 0.7em;\n",
"}\n",
".highlight-code {\n",
"white-space: pre;\n",
"font-family: monospace;\n",
"}\n",
".suggestion-warning { \n",
"font-weight: bold;\n",
"color: rgb(200, 130, 0);\n",
"}\n",
".suggestion-error { \n",
"font-weight: bold;\n",
"color: red;\n",
"}\n",
".suggestion-name {\n",
"font-weight: bold;\n",
"}\n",
"</style><span class='get-type'>fact' :: forall p. (Eq p, Num p) => (p -> p) -> p -> p</span>"
],
"text/plain": [
"fact' :: forall p. (Eq p, Num p) => (p -> p) -> p -> p"
]
},
"metadata": {},
"output_type": "display_data"
},
{
"data": {
"text/plain": [
@ -443,14 +550,22 @@
}
],
"source": [
"{-# LANGUAGE FlexibleContexts #-}\n",
"\n",
"-- https://hackage.haskell.org/package/base-4.12.0.0/docs/Control-Monad-Fix.html\n",
"import Control.Monad.Fix\n",
"\n",
"-- fix :: (a -> a) -> a\n",
"-- fix f = let {x = f x} in x\n",
"\n",
"let fac n = if n <= 1 then 1 else n * fac (n-1) in fac 5\n",
"\n",
"fix (\\rec n -> if n <= 1 then 1 else n * rec (n-1)) 5\n",
"\n",
"-- fact' rec n = if n == 0 then 1 else n * rec (n-1)\n",
"-- fix fact' 5\n",
"fact' rec n = if n == 0 then 1 else n * rec (n-1)\n",
"\n",
":t fact'\n",
"\n",
"-- f = fact' f\n",
"-- = \\n -> if n == 0 then 1 else n * f (n-1)\n",
@ -470,12 +585,14 @@
" else (n-1) * (if n-2 == 0 then 1\n",
" else (n-2) * fix fact' (n-3)))\n",
"= ...\n",
"-}"
"-}\n",
"\n",
"fix fact' 5"
]
},
{
"cell_type": "code",
"execution_count": 15,
"execution_count": 5,
"metadata": {},
"outputs": [
{
@ -579,6 +696,8 @@
"source": [
"data FixE f e = Fix (f (FixE f e)) | Throw e\n",
"\n",
"-- data Free f r = Free (f (Free f r)) | Pure r\n",
"\n",
"catch :: (Functor f) => FixE f e1 -> (e1 -> FixE f e2) -> FixE f e2\n",
"catch (Fix x) f = Fix (fmap (flip catch f) x)\n",
"catch (Throw e) f = f e\n",
@ -592,6 +711,7 @@
"\n",
"-- output 'A'\n",
"-- throw IncompleteException\n",
"-- output 'B'\n",
"subroutine = Fix (Output 'A' (Throw IncompleteException)) :: FixE (Toy Char) IncompleteException\n",
"\n",
"-- try {subroutine}\n",
@ -604,7 +724,7 @@
},
{
"cell_type": "code",
"execution_count": 23,
"execution_count": 6,
"metadata": {},
"outputs": [
{
@ -691,10 +811,10 @@
".suggestion-name {\n",
"font-weight: bold;\n",
"}\n",
"</style><span class='get-type'>output :: forall b. b -> Free (Toy b) ()</span>"
"</style><span class='get-type'>output :: forall b (m :: * -> *). MonadFree (Toy b) m => b -> m ()</span>"
],
"text/plain": [
"output :: forall b. b -> Free (Toy b) ()"
"output :: forall b (m :: * -> *). MonadFree (Toy b) m => b -> m ()"
]
},
"metadata": {},
@ -784,10 +904,10 @@
".suggestion-name {\n",
"font-weight: bold;\n",
"}\n",
"</style><span class='get-type'>bell :: forall b. Free (Toy b) ()</span>"
"</style><span class='get-type'>bell :: forall b (m :: * -> *). MonadFree (Toy b) m => m ()</span>"
],
"text/plain": [
"bell :: forall b. Free (Toy b) ()"
"bell :: forall b (m :: * -> *). MonadFree (Toy b) m => m ()"
]
},
"metadata": {},
@ -877,10 +997,10 @@
".suggestion-name {\n",
"font-weight: bold;\n",
"}\n",
"</style><span class='get-type'>done :: forall b r. Free (Toy b) r</span>"
"</style><span class='get-type'>done :: forall b (m :: * -> *) a. MonadFree (Toy b) m => m a</span>"
],
"text/plain": [
"done :: forall b r. Free (Toy b) r"
"done :: forall b (m :: * -> *) a. MonadFree (Toy b) m => m a"
]
},
"metadata": {},
@ -900,6 +1020,18 @@
"-}\n",
"\n",
"{-|\n",
"(>>=) :: forall a b. m a -> (a -> m b) -> m b\n",
"catch :: (Functor f) => FixE f e1 -> (e1 -> FixE f e2) -> FixE f e2\n",
"\n",
"FixE f --- m\n",
"e1 --- a\n",
"e2 --- b\n",
"\n",
"catch -- >>=\n",
"Throw -- Pure\n",
"-}\n",
"\n",
"{-|\n",
"output :: a -> Free (Toy a) ()\n",
"output x = Free (Output x (Pure ()))\n",
"\n",
@ -913,6 +1045,10 @@
"liftF command = Free (fmap Pure command)\n",
"-}\n",
"\n",
"-- There is some Functor f => Free f is a monad\n",
"\n",
"-- Toy b is a Functor, Free (Toy b) is a monad\n",
"\n",
"output x = liftF (Output x ())\n",
"bell = liftF (Bell ())\n",
"done = liftF Done\n",
@ -926,6 +1062,7 @@
"\n",
"program :: Free (Toy Char) r\n",
"program = do\n",
" bell\n",
" subroutine\n",
" bell\n",
" done"
@ -933,12 +1070,13 @@
},
{
"cell_type": "code",
"execution_count": 24,
"execution_count": 7,
"metadata": {},
"outputs": [
{
"data": {
"text/plain": [
"bell\n",
"output 'A'\n",
"bell\n",
"done"
@ -1134,24 +1272,6 @@
"pretty (output 'A' >> (done >> output 'C'))"
]
},
{
"cell_type": "code",
"execution_count": 27,
"metadata": {},
"outputs": [],
"source": [
"import Control.Exception\n",
"\n",
"ringBell :: IO ()\n",
"ringBell = undefined\n",
"\n",
"interpret :: (Show b) => Free (Toy b) r -> IO ()\n",
"interpret (Free (Output b x)) = print b >> interpret x\n",
"interpret (Free (Bell x)) = ringBell >> interpret x\n",
"interpret (Free Done ) = return ()\n",
"interpret (Pure r) = throwIO (userError \"Improper termination\")"
]
},
{
"cell_type": "code",
"execution_count": 43,
@ -1172,6 +1292,55 @@
"-}"
]
},
{
"cell_type": "code",
"execution_count": 9,
"metadata": {},
"outputs": [],
"source": [
"{-|\n",
"\n",
"data Request =\n",
" Look Direction\n",
" | ReadLine\n",
" | Fire Direction\n",
" | WriteLine String\n",
" \n",
"data Response =\n",
" Image Picture -- Response for Look\n",
" | ChatLine String -- Response for Read\n",
" | Succeeded Bool -- Response for Write\n",
" \n",
"data Interaction next =\n",
" Look Direction (Image -> next)\n",
" | Fire Direction next\n",
" | ReadLine (String -> next)\n",
" | WriteLine String (Bool -> next)\n",
" \n",
"instance Functor Interaction where\n",
" fmap f (Look dir g) = Look dir (f . g)\n",
" fmap f (Fire dir x) = Fire dir (f x)\n",
" fmap f (ReadLine g) = ReadLine (f . g)\n",
" fmap f (WriteLine s g) = WriteLine s (f . g)\n",
" \n",
"interpret :: Program r -> Game r\n",
"interpret prog = case prog of\n",
" Free (Look dir g) -> do\n",
" img <- collectImage dir\n",
" interpret (g img)\n",
" Free (Fire dir next) -> do\n",
" sendBullet dir\n",
" interpret next\n",
" Free (ReadLine g) -> do\n",
" str <- getChatLine\n",
" interpret (g str)\n",
" Free (WriteLine s g) ->\n",
" putChatLine s\n",
" interpret (g True)\n",
" Pure r -> return r\n",
"-}"
]
},
{
"cell_type": "code",
"execution_count": 45,