diff --git a/freemonad.ipynb b/freemonad.ipynb
index 78a3d99..587f411 100644
--- a/freemonad.ipynb
+++ b/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": [
+ "fact' :: forall p. (Eq p, Num p) => (p -> p) -> p -> p"
+ ],
+ "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",
- "output :: forall b. b -> Free (Toy b) ()"
+ "output :: forall b (m :: * -> *). MonadFree (Toy b) m => b -> m ()"
],
"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",
- "bell :: forall b. Free (Toy b) ()"
+ "bell :: forall b (m :: * -> *). MonadFree (Toy b) m => m ()"
],
"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",
- "done :: forall b r. Free (Toy b) r"
+ "done :: forall b (m :: * -> *) a. MonadFree (Toy b) m => m a"
],
"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,