rec schemes

rec.hs

{-# language TupleSections #-}
module Main where

data ListF a b = NilF | ConsF a b deriving Functor
data NatF a = ZeroF | SuccF a deriving Functor
data StreamF a b = StreamF a b deriving Functor

newtype Fix f = Fix {unfix :: f (Fix f)}

type Algebra f a = f a -> a
type CoAlgebra f a = a -> f a

cata :: Functor f => (f a -> a) -> Fix f -> a
cata alg = alg . fmap (cata alg) . unfix

ana :: Functor f => (a -> f a) -> a -> Fix f
ana coalg = Fix . fmap (ana coalg) . coalg

hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b
hylo alg coalg = alg . fmap (cata alg . ana coalg) . coalg

para :: Functor f => (f (Fix f, a) -> a) -> Fix f -> a
para alg = alg . fmap (id &&& para alg) . unfix
  where (f &&& g) x = (f x, g x)

apo :: Functor f => (a -> f (Either (Fix f) a)) -> a -> Fix f
apo coalg = Fix . fmap (id ||| apo coalg) . coalg
  where 
      (f ||| g) (Left x)  = f x
      (f ||| g) (Right y) = g y

accu :: Functor f => (forall x. f x -> p -> f (x, p)) -> (f a -> p -> a) -> Fix f -> p -> a
accu st alg (Fix t) p = alg (fmap (uncurry (accu st alg)) (st t p)) p

fromList :: [a] -> Fix (ListF a)
fromList [] = Fix NilF
fromList (x:xs) = Fix (ConsF x (fromList xs))

toList :: Fix (ListF a) -> [a]
toList (Fix NilF) = []
toList (Fix (ConsF x xs)) = x : toList xs

stream2list :: StreamF a [a] -> [a]
stream2list (StreamF x y) = x : y

toNat :: Int -> Fix NatF
toNat 0 = Fix ZeroF
toNat n = Fix (SuccF (toNat (n-1)))

fromNat :: Fix NatF -> Int
fromNat (Fix ZeroF) = 0
fromNat (Fix (SuccF x)) = 1 + fromNat x

import Data.Semigroup
import Data.List
import Debug.Trace ( trace )
import qualified Data.Map.Strict as M
import Data.Bifunctor (bimap)

-- number io
numberIO :: Float -> Integer -> Float
numberIO x y = x + fromInteger y

-- smallOrLarge
smallOrLarge :: Int -> String
smallOrLarge x
  | (< 1000) x = "small"
  | (> 2000) x  = "large"
  | otherwise  = ""

-- for loop index
forLoopIndex :: Int -> Int -> Int -> [Int]
forLoopIndex start end step = toList $ ana coalg start
  where
    coalg seed
      | seed == end = NilF
      | otherwise   = ConsF seed (seed + step)

-- compareStrLen
compareStrLen :: String -> String -> String -> Bool
compareStrLen x1 x2 x3 = length x1 < length x2 && length x2 < length x3

-- double letters
doubleLetters :: String -> String
doubleLetters xs = accu st alg (fromList xs) []
  where
    st NilF s = NilF
    st (ConsF x xs) s = ConsF x (xs, if x == '!' then "!!!" else if isLetter x then [x,x] else [x])

    alg NilF s         = s
    alg (ConsF x xs) s = s <> xs

    -- assume we have that
    snoc y ys = ys <> [y]
    isLetter c = c `elem` (['A' .. 'Z'] <> ['a' .. 'z'])

-- collatz
collatz :: Int -> Int
collatz = cata alg . apo coalg
  where
      alg NilF = 0
      alg (ConsF x xs) = 1 + xs

      coalg x = ConsF x $ if x == 1 
                           then Left (Fix NilF)
                           else (Right $ if even x then div x 2 else div (3*x + 1) 2)

-- replace space with newline 
replaceSpaceCount :: String -> (String, Int)
replaceSpaceCount xs = accu st alg (fromList xs) 0
  where
    st NilF s = NilF
    st (ConsF x xs) s = ConsF (if x==' ' then '\n' else x) (xs, if x == ' ' then 1 else 0)
    alg NilF s         = ("", s)
    alg (ConsF x xs) s = bimap (x:) (s+) xs

stringDiffs :: String -> String -> [(Int, (Char, Char))]
stringDiffs xs ys = accu st alg (fromList $ zip xs ys) 0
  where
    st NilF s = NilF
    st (ConsF x xs) s = ConsF x (xs, s+1)
    alg NilF s = []
    alg (ConsF x xs) s = if uncurry (/=) x then (s, x) : xs else xs

evenSquares :: Int -> [Int]
evenSquares n = toList $ ana coalg 2
  where
    coalg seed
      | seed^2 >= n = NilF
      | otherwise   = ConsF (seed^2) (seed + 2)

wallisPi :: Int -> Double
wallisPi = hylo alg coalg
  where
    alg NilF = 1.0
    alg (ConsF x xs) = x * xs
    coalg x = if x == 0
                then NilF
                else ConsF (fromIntegral (4 * x ^ 2) / fromIntegral ((2*x - 1)*(2*x + 1))) (x-1)

strLenBack :: [String] -> [Int]
strLenBack xs = accu st alg (fromList xs) []
  where
    st NilF s = NilF
    st (ConsF x xs) s = ConsF x (xs, length x : s)
    alg NilF s = s
    alg (ConsF x xs) s = xs

lastIndexZero :: [Int] -> Maybe (Last Int)
lastIndexZero xs = accu st alg (fromList xs) 0
  where
    st NilF s = NilF
    st (ConsF x xs) s = ConsF x (xs, s+1)

    alg NilF s = Nothing
    alg (ConsF x xs) s = if x == 0 then Just (Last s) <> xs  else xs 

    --alternative if you don't like maybe
    --alg NilF s = -1
    --alg (ConsF x xs) s = if x == 0 && xs == -1 then s else xs

vecAvg :: [Double] -> Double
vecAvg xs = accu st alg (fromList xs) (0.0, 0.0)
  where
    st NilF s = NilF
    st (ConsF x xs) s = ConsF x (xs, (fst s + x, snd s + 1))
    alg NilF s = uncurry (/) s
    alg (ConsF x xs) s = xs

countOdds :: [Int] -> Int
countOdds = cata alg . fromList
  where
    alg NilF = 0
    alg (ConsF x xs) = xs + mod x 2

mirrorImage :: [Int] -> [Int] -> Bool
mirrorImage xs ys = accu st alg (fromList xs) ys
  where
    st NilF s = NilF
    st (ConsF x xs) s = ConsF x (xs, init s)
    alg NilF s = null s
    alg (ConsF x xs) s = (not . null) s && xs && last s == x

superAnagram :: String -> String -> Bool
superAnagram xs ys = accu st alg (fromList xs) ys
  where
    st NilF s = NilF
    st (ConsF x xs) s = ConsF x (xs, delete x s)
    alg NilF s = True
    alg (ConsF x xs) s = xs && x `elem` s

sumOfSquares :: [Int] -> Int
sumOfSquares = cata alg . fromList
  where
    alg NilF = 0
    alg (ConsF x xs) = x^2 + xs

sumOfVecs :: [Int] -> [Int] -> [Int]
sumOfVecs xs ys = accu st alg (fromList xs) ys
  where
    st NilF s = NilF
    st (ConsF x xs) s = ConsF x (xs, tail s)
    alg NilF s = []
    alg (ConsF x xs) s = (x + head s) : xs

xWordLines :: Int -> String -> [String]
xWordLines n = toList . ana coalg . words
  where
    coalg ws = if null ws 
                 then NilF 
                 else let (x, y) = splitAt n ws in ConsF (unwords x) y

pigLatin :: String -> String
pigLatin xs = accu st alg (fromList $ words xs) []
  where
    st NilF s = NilF
    st (ConsF x xs) s = ConsF x (xs, if (head x) `elem` "aeiouAEIOU" then x <> "ay" else tail x <> (head x : "ay"))
    alg NilF s = []
    alg (ConsF x xs) s = s <> " " <> xs

negativeToZero :: [Int] -> [Int]
negativeToZero = cata alg . fromList
  where
    alg NilF = []
    alg (ConsF x xs) = max 0 x : xs

scrabbleScore :: String -> Int
scrabbleScore = cata alg . fromList
  where 
   alg NilF = 0
   alg (ConsF x xs) = M.findWithDefault 0 x scores + xs
   scores = M.fromList $ concat [map (,1) "AEIOULNSTR", map (,2) "DG", map (,4) "FHVWY", [('K',5)], map (,8) "JX", map (,10) "QX"]

wordDist :: String -> M.Map Int Int
wordDist xs = accu st alg (fromList $ words xs) M.empty
  where
    st NilF s = NilF
    st (ConsF x xs) s = ConsF x (xs, M.insertWith (+) (length x) 1 s)
    alg NilF s = s
    alg (ConsF x xs) s = xs

lineCount :: String -> Int
lineCount = cata alg . fromList
  where
    alg NilF = 1
    alg (ConsF x xs) = xs + if x=='\n' then 1 else 0

avgLineLen :: String -> Double
avgLineLen xs = accu st alg (fromList $ lines xs) (0.0, 0.0)
  where
    st NilF s = NilF
    st (ConsF x xs) s = ConsF x (xs, bimap (fromIntegral (length x) +) (1 +) s)
    alg NilF s = uncurry (/) s
    alg (ConsF x xs) s = xs

checksum :: String -> Char
checksum = toEnum . cata alg . fromList
  where
    alg NilF = fromEnum ' '
    alg (ConsF x xs) = mod (fromEnum x + xs) 64

digits :: Int -> [Int]
digits = toList . ana coalg
  where
    coalg x = if x == 0 then NilF else ConsF ((if abs x < 10 then id else abs) $ x `rem` 10) (x `quot` 10)

grade :: [Double] -> Double -> Char
grade thrs n = accu st alg (fromList thrs) "ABCDF"
  where
    st NilF s = NilF
    st (ConsF x xs) s = ConsF x (xs, if n < x then tail s else s)
    alg NilF s = head s
    alg (ConsF x xs) s = xs

median :: Int -> Int -> Int -> Int
median x y z = accu st alg (fromList [x, y, z]) (x, y, 0)
  where
    st NilF s = NilF
    st (ConsF x xs) (a, b, c) = ConsF x (xs, (min x a, max x b, x + c))
    alg NilF (a, b, c) = c - a - b
    alg (ConsF x xs) s = xs

smallest :: Int -> Int -> Int -> Int -> Int
smallest x y z w = cata alg (fromList [y,z,w])
  where
    alg NilF = x
    alg (ConsF x xs) = min x xs

syllables :: String -> Int
syllables = cata alg . fromList
  where
    alg NilF = 0
    alg (ConsF x xs) = xs + if x `elem` "aeiouyAEIOUY" then 1 else 0

main :: IO ()
main = do
  print $ numberIO 2.1 3
  print $ map smallOrLarge [500, 2500, 1500]
  print $ forLoopIndex 10 100 10
  print $ map (compareStrLen "hi" "hello") ["world", "world!"]
  print $ doubleLetters "Hello! World!!"
  print $ collatz 27
  print $ replaceSpaceCount "Hello world with spaces"
  print $ stringDiffs "dealer" "dollars"
  print $ evenSquares 100
  print $ wallisPi 1000
  print $ strLenBack ["Hello", "World!!", "Haskell", "Mighty", "Morphisms"]
  print $ lastIndexZero [1, 2, 3, 4, 0, 5, 6, 0, 7]
  print $ vecAvg [1, 2, 3, 4, 5]
  print $ countOdds [1, 2, 3, 4, 5]
  print $ mirrorImage [1, 2, 3, 4] [4, 3, 2, 1]
  print $ mirrorImage [1, 2, 3, 4] [4, 3, 2]
  print $ mirrorImage [1, 2, 3] [4, 3, 2, 1]
  print $ mirrorImage [1, 2, 3, 4] [4, 3, 1, 2]
  print $ superAnagram "haskell eh bom" "lhkesa lhe mob"
  print $ superAnagram "haskell eh bom" "lhkesa lhe ob"
  print $ sumOfSquares [1 .. 5]
  print $ sumOfVecs [1 .. 5] [2 .. 6]
  print $ xWordLines 2 "Haskell is good\nHaskell is not bad"
  print $ pigLatin "About time to upper love"
  print $ negativeToZero [1, -2, 3, 4, -5, -6, 7, -8, 9]
  print $ scrabbleScore "Haskell"
  print $ wordDist "Haskell is good Haskell\nis not bad"
  print $ lineCount "Haskell is good Haskell\nis not bad"
  print $ avgLineLen "Haskell is good Haskell\nis not bad"
  print $ checksum "Haskell is good Haskell\nis not bad"
  print $ digits (-1234)
  print $ grade [9, 7, 6, 5] 5
  print $ grade [9, 7, 6, 5] 3
  print $ grade [9, 7, 6, 5] 6.5
  print $ grade [9, 7, 6, 5] 7.2
  print $ grade [9, 7, 6, 5] 10
  print $ median 5 3 1
  print $ smallest 3 1 2 4
  print $ syllables "Haskell is good Haskell\nis not bad"