From 65425cf618f348ed89e9d07706fa28338f84f0b5 Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Tue, 7 Aug 2018 15:32:21 -0700
Subject: Add ski calculus interpretor

---
 ski.hs | 70 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 70 insertions(+)
 create mode 100755 ski.hs

diff --git a/ski.hs b/ski.hs
new file mode 100755
index 0000000..b0ea4d8
--- /dev/null
+++ b/ski.hs
@@ -0,0 +1,70 @@
+#! /usr/bin/env nix-shell
+#! nix-shell -p haskellPackages.ghc -i runghc
+
+{-# OPTIONS_GHC -Wall #-}
+
+-- An expression in the SKI calculus is either S, K, I, or an application Ap of
+-- any of 2 those combinators together.
+data Expr
+  = S
+  | K
+  | I
+  | Ap Expr Expr
+  deriving (Show, Eq)
+
+-- The eval function is the only function we need. It takes an expression and
+-- returns an expresison.
+
+eval :: Expr -> Expr
+
+-- First define the S combinator. We evaluate in a strict fashion, from the left
+-- to the right, so the placement of the parens must reflect this order of
+-- operations.
+
+eval S = S
+eval (Ap (Ap (Ap S x) y) z) = eval (Ap (Ap x z) (Ap y z))
+eval (Ap S x) = Ap S (eval x)
+
+-- K and I combinators are simpler:
+
+eval K = K
+eval (Ap (Ap K x) _) = eval x
+eval (Ap K x) = Ap K (eval x)
+
+eval I = I
+eval (Ap I x) = eval x
+
+-- One benefit of doing this in Haskell is the compiler can do exaustive pattern
+-- checking for us to make sure that we've covered every combination of S, K,
+-- and I possible in our little language defined by 'Expr'.
+--
+-- In this case, the compiler warns that we don't have a case for 
+--
+--     (Ap (Ap _ _) _)
+--
+-- so we just define that by recursing onto each branch of the Expr tree. But
+-- first we check for branch equality, to avoid infinite recursion:
+--
+eval (Ap a b) =
+  if a == a' && b == b'
+    then (Ap a b)
+    else eval (Ap a' b')
+  where
+    a' = eval a
+    b' = eval b
+
+-- Some example tests:
+main :: IO ()
+main = do
+  putStrLn $ "Expect I: " ++ show i
+  putStrLn $ "Expect K: " ++ show k
+  putStrLn $ "Expect K: " ++ show s
+  putStrLn $ "Expect S: " ++ show kiss
+  putStrLn $ "Expect SKSISKKI: " ++ show a
+  where
+    i = eval (Ap I I) -- I I = I
+    k = eval (Ap (Ap K K) I) -- K K I = K
+    s = eval (Ap (Ap (Ap S K) S) K) -- S K S K = K K (S K) = K
+        -- (S (K (S I)) (S (K K) I))
+    a = eval (Ap (Ap S (Ap K (Ap S I))) (Ap (Ap S (Ap K K)) I))
+    kiss = eval (Ap (Ap (Ap K I) S) S)
-- 
cgit v1.2.3