freemonad: Update the Free monad notebook
Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>
This commit is contained in:
parent
91050d615a
commit
cce60e0790
1 changed files with 201 additions and 32 deletions
233
freemonad.ipynb
233
freemonad.ipynb
|
|
@ -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,
|
||||
|
|
|
|||
Loading…
Reference in a new issue