1 files changed, 153 insertions, 0 deletions
diff --git a/1-kyu/scott-encoding.hs b/1-kyu/scott-encoding.hs
new file mode 100644
index 0000000..ff133ca
--- /dev/null
+++ b/1-kyu/scott-encoding.hs
@@ -0,0 +1,153 @@
+-- https://www.codewars.com/kata/59c132fb70a3b7efd3000024
+{-# LANGUAGE ScopedTypeVariables, Rank2Types #-}
+module ScottEncoding where
+
+import Prelude hiding (null, length, map, foldl, foldr, take, fst, snd, curry, uncurry, concat, zip, (++))
+
+newtype SPair a b = SPair { runPair :: forall c. (a -> b -> c) -> c }
+
+toPair :: SPair a b -> (a,b)
+toPair p = (fst p, snd p)
+
+fromPair :: (a,b) -> SPair a b
+fromPair (a, b) = SPair $ \f -> f a b
+
+fst :: SPair a b -> a
+fst p = runPair p (\a b -> a)
+
+snd :: SPair a b -> b
+snd p = runPair p (\a b -> b)
+
+swap :: SPair a b -> SPair b a
+swap p = fromPair (b, a) where
+  a = fst p
+  b = snd p
+
+curry :: (SPair a b -> c) -> (a -> b -> c)
+curry f = \a b -> f $ fromPair (a, b)
+
+uncurry :: (a -> b -> c) -> (SPair a b -> c)
+uncurry f = \p -> f (fst p) (snd p)
+
+newtype SMaybe a = SMaybe { runMaybe :: forall b. b -> (a -> b) -> b }
+
+toMaybe :: SMaybe a -> Maybe a
+toMaybe sm = runMaybe sm Nothing Just
+
+fromMaybe :: Maybe a -> SMaybe a
+fromMaybe m = SMaybe $ case m of
+    Just x -> \b f -> f x
+    Nothing -> \b f -> b
+
+isJust :: SMaybe a -> Bool
+isJust sm = runMaybe sm False $ const True
+
+isNothing :: SMaybe a -> Bool
+isNothing sm = runMaybe sm True $ const False
+
+catMaybes :: SList (SMaybe a) -> SList a
+catMaybes slm = go slm $ fromList [] where
+  go l r =
+    if null l then sreverse r
+    else
+      let x = car l
+      in
+        case toMaybe x of
+          Just x -> go (cdr l) (cons x r)
+          Nothing -> go (cdr l) r 
+
+newtype SEither a b = SEither { runEither :: forall c. (a -> c) -> (b -> c) -> c }
+
+toEither :: SEither a b -> Either a b
+toEither se = runEither se Left Right
+
+fromEither :: Either a b -> SEither a b
+fromEither e = SEither $ case e of
+    Left x -> \l r -> l x
+    Right x -> \l r -> r x
+
+isLeft :: SEither a b -> Bool
+isLeft se = runEither se (const True) (const False)
+
+isRight :: SEither a b -> Bool
+isRight se = runEither se (const False) (const True)
+
+partition :: SList (SEither a b) -> SPair (SList a) (SList b)
+partition sle = go sle (fromList []) (fromList []) where
+  go sle sll slr =
+    if null sle then fromPair (sreverse sll, sreverse slr)
+    else
+      case toEither (car sle) of
+        Left x -> go (cdr sle) (cons x sll) slr
+        Right x -> go (cdr sle) sll (cons x slr)
+
+newtype SList a = SList { runList :: forall b. b -> (a -> SList a -> b) -> b }
+
+toList :: SList a -> [a]
+toList sl = runList sl [] (\x xs -> x:toList xs)
+
+fromList :: [a] -> SList a
+fromList [] = SList $ \nil _ -> nil
+fromList (x:xs) = SList $ \_ f -> f x $ fromList xs
+
+cons :: a -> SList a -> SList a
+cons  x xs = SList $ \_ f -> f x xs
+
+null :: SList a -> Bool
+null sl = runList sl True $ \x xs -> False
+
+car :: SList a -> a
+car sl = runList sl (error "cannot car on null list") $ \x xs -> x
+
+cdr :: SList a -> SList a
+cdr sl = runList sl (error "cannot car on null list") $ \x xs -> xs
+
+sreverse :: SList a -> SList a
+sreverse sl = go sl $ fromList [] where
+  go l r =
+    if null l then r
+    else go (cdr l) (cons (car l) r)
+
+concat :: SList a -> SList a -> SList a
+concat sla slb = go (sreverse sla) slb where
+  go la lb =
+    if null la then lb
+    else
+      go (cdr la) (cons (car la) lb)
+
+length :: SList a -> Int
+length sl = go sl 0 where
+  go sl l =
+    if null sl then l
+    else
+      go (cdr sl) (l+1)
+
+map :: (a -> b) -> SList a -> SList b
+map f sl = go sl $ fromList [] where
+  go sl r =
+    if null sl then sreverse r
+    else
+      go (cdr sl) (cons (f (car sl)) r)
+
+zip :: SList a -> SList b -> SList (SPair a b)
+zip sla slb = go sla slb (fromList []) where
+  go l1 l2 r = 
+    if null l1 || null l2 then sreverse r
+    else
+      go (cdr l1) (cdr l2) (cons (fromPair (car l1, car l2)) r)
+
+foldl :: (b -> a -> b) -> b -> SList a -> b
+foldl f init sl =
+  if null sl then init
+  else
+    foldl f (f init (car sl)) (cdr sl)
+
+foldr :: (a -> b -> b) -> b -> SList a -> b
+foldr f init sl = foldl (flip f) init (sreverse sl)
+
+take :: Int -> SList a -> SList a
+take i sl = go i sl $ fromList [] where
+  go i sl r
+    | i <= 0 = sreverse r
+    | null sl = sreverse r
+    | otherwise = go (i-1) (cdr sl) (cons (car sl) r)