freemonad: Update the Free monad notebook

Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>

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,