: extension NoMonomorphismRestriction import Diagrams.Prelude data U x = U [ x ] x [ x ] instance Functor U where fmap f ( U a b c ) = U ( fmap f a ) ( f b ) ( fmap f c ) class Functor w => Comonad w where coreturn :: w a -> a cojoin :: w a -> w ( w a ) ( =>> ) :: ( w a ) -> ( w a -> b ) -> w b x =>> f = fmap f ( cojoin x ) left ( U a b ( c : cs )) = U ( b : a ) c cs right ( U ( a : as ) b c ) = U as a ( b : c ) iterate1 f x = tail $ iterate f x instance Comonad U where coreturn ( U _ x _ ) = x cojoin x = U ( iterate1 left x ) x ( iterate1 right x ) rule :: U Bool -> Bool rule ( U ( a : _ ) b ( c : _ )) = not ( a && b && not c || ( a == b )) start = U ( repeat False ) True ( repeat False ) instance Show x => Show ( U x ) where show ( U a b c ) = show ( take 10 a ) ++ show b ++ show ( take 10 c ) generations = iterate ( =>> rule ) start shift :: Int -> U x -> U x shift i x = iterate ( if i > 0 then right else left ) x ! ! ( abs i ) rightHalf :: U x -> [ x ] rightHalf ( U _ b c ) = b : c toList :: Int -> Int -> U x -> [ x ] toList i j x = take ( j - i ) $ rightHalf $ shift ( - i ) x makeGrey x = fc $ darken x white dist displacement = cat ' (r2 (1,0) ) (with & catMethod .~ Distrib & sep .~ displacement ) dia = dist 1 . fmap ( \ x -> square 1 # makeGrey (if x then 1.0 else 0.0) ) diagram $ vcat $ take 30 $ fmap ( dia . toList ( - 20 ) 20 ) generations