Created
July 19, 2017 01:28
-
-
Save Cedev/c9f3769eb7bab6eea6c323925cae8215 to your computer and use it in GitHub Desktop.
tape comonad
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {-# language DeriveFunctor #-} | |
| {-# language FlexibleInstances #-} | |
| import Data.Function | |
| class Functor w => Comonad w where | |
| extract :: w a -> a | |
| duplicate :: w a -> w (w a) | |
| kfix :: ComonadApply w => w (w a -> a) -> w a | |
| kfix w = fix $ \u -> w <@> duplicate u | |
| class Comonad w => ComonadApply w where | |
| (<@>) :: w (a -> b) -> w a -> w b | |
| data Stream a = Stream a (Stream a) | |
| deriving (Show, Eq, Functor) | |
| advance :: Stream a -> Stream a | |
| advance ~(Stream _ s) = s | |
| iterateS :: (a -> a) -> a -> Stream a | |
| iterateS f x = Stream x (iterateS f (f x)) | |
| repeatS :: a -> Stream a | |
| repeatS a = fix (Stream a) | |
| toList :: Stream a -> [a] | |
| toList (Stream a s) = a:toList s | |
| instance Comonad Stream where | |
| extract ~(Stream a _) = a | |
| duplicate w = iterateS advance w | |
| instance ComonadApply Stream where | |
| ~(Stream f fs) <@> ~(Stream a as) = Stream (f a) (fs <@> as) | |
| data Tape a = Tape (Stream a) a (Stream a) | |
| deriving (Show, Eq, Functor) | |
| moveLeft :: Tape a -> Tape a | |
| moveLeft ~(Tape ~(Stream l ls) a rs) = Tape ls l (Stream a rs) | |
| moveRight :: Tape a -> Tape a | |
| moveRight ~(Tape ls a ~(Stream r rs)) = Tape (Stream a ls) r rs | |
| {- | |
| productively :: Tape a -> Tape a | |
| productively ~(Tape ls a rs) = Tape ls a rs | |
| moveLeft, moveRight :: Tape a -> Tape a | |
| moveLeft w = productively $ | |
| case w of | |
| Tape [] _ _ -> w | |
| Tape (l:ls) a rs -> Tape ls l (a:rs) | |
| moveRight w = productively $ | |
| case w of | |
| Tape _ _ [] -> w | |
| Tape ls a (r:rs) -> Tape (a:ls) r rs | |
| -} | |
| instance Comonad Tape where | |
| extract ~(Tape _ a _) = a | |
| duplicate w@(~(Tape ls _ rs)) = Tape lefts w rights | |
| where | |
| lefts = advance $ iterateS moveLeft w | |
| rights = advance $ iterateS moveRight w | |
| instance ComonadApply Tape where | |
| ~(Tape l f r) <@> ~(Tape l' a r') = Tape (l <@> l') (f a) (r <@> r') | |
| rightBy :: Int -> Tape a -> a | |
| rightBy x w | x >= 0 = extract $ iterate moveRight w !! x | |
| | x < 0 = leftBy (-x) w | |
| leftBy :: Int -> Tape a -> a | |
| leftBy x w | x >= 0 = extract $ iterate moveLeft w !! x | |
| | x < 0 = rightBy (-x) w | |
| stream :: [a] -> a -> Stream a | |
| stream [] bg = repeatS bg | |
| stream (a:as) bg = Stream a (stream as bg) | |
| tape :: a -> [a] -> a -> Tape a | |
| tape left middle right = Tape (repeatS left) a s | |
| where | |
| (Stream a s) = stream middle right | |
| tapeKFix :: Tape Int | |
| tapeKFix = kfix $ tape (const 0) [const 1, const 1] ((+) <$> leftBy 2 <*> leftBy 1) | |
| main = print $ fmap extract $ take 100 $ iterate moveRight $ tapeKFix |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment