dragon curve experiments

dragon.hs

{-# LANGUAGE RankNTypes, GADTs, ConstraintKinds, ScopedTypeVariables, DeriveFunctor #-}

import Data.Monoid
import Data.Foldable (toList)
import Data.Constraint (Dict(..))
import qualified Data.DList as DList
import qualified Data.Sequence as Seq

class (Functor f) => DragonList f where
    singleton :: a -> f a
    rev :: f a -> f a
    monoid :: Dict (Monoid (f a))

fromList :: forall f a. DragonList f => [a] -> f a
fromList = case monoid :: Dict (Monoid (f a)) of Dict -> foldMap singleton

dragonCurveN :: Int -> [Bool] -> [Bool]
dragonCurveN n s = iterate f s !! n
    where
    f s = s ++ [False] ++ (map not . reverse) s

dragonAlgo :: forall f. (DragonList f) => f Bool -> f Bool -> f Bool
dragonAlgo =
    case monoid :: Dict (Monoid (f Bool)) of 
        Dict ->
            let gen a b = 
                 let b' = (fmap not . rev) b
                     r = singleton False <> (b' <> a)
                 in r <> gen (b' <> a) r
            in gen

-- 001001100110
-- 001001100011011 0 001001110011011

-- gen []  []   = 0        ++ 
-- gen []  0    = 01       ++ 
-- gen 1   01   = 0011     ++
-- gen 011 0011 = 00011011 ++
-- gen 0011011 00011011 = 0001001110011011


instance DragonList [] where
    singleton x = [x]
    rev = reverse
    monoid = Dict

dragonCurveList :: [Bool] -> [Bool]
dragonCurveList = dragonAlgo []


newtype FM a = FM { runFM :: forall m. (Monoid m) => (a -> m) -> m }

instance Monoid (FM a) where
    mempty = FM $ const mempty
    FM m `mappend` FM m' = FM (\x -> m x `mappend` m' x)

instance Functor FM where
    fmap f (FM m) = FM $ \c -> m (c . f)

instance Foldable FM where
    foldMap f (FM m) = m f

instance DragonList FM where
    singleton x = FM $ \c -> c x
    rev (FM m) = FM (\c -> getDual (m (Dual . c)))
    monoid = Dict

dragonCurveFM :: [Bool] -> [Bool]
dragonCurveFM = toList . dragonAlgo (mempty :: FM Bool) . fromList


data RevTree a 
    = Empty
    | Singleton !a
    | Concat (RevTree a) (RevTree a)
    | Reverse (RevTree a)
    deriving (Functor)

instance Foldable RevTree where
    foldMap f = foldMap f . forward
        where
        forward Empty = mempty
        forward (Singleton a) = DList.singleton a
        forward (Concat a b) = forward a <> forward b
        forward (Reverse t) = backward t
        backward Empty = mempty
        backward (Singleton a) = DList.singleton a
        backward (Concat a b) = backward b <> backward a
        backward (Reverse t) = forward t

instance Monoid (RevTree a) where
    mempty = Empty
    mappend = Concat

instance DragonList RevTree where
    singleton = Singleton
    rev = Reverse
    monoid = Dict

dragonCurveRevTree :: [Bool] -> [Bool]
dragonCurveRevTree = toList . dragonAlgo (mempty :: RevTree Bool) . fromList


instance DragonList Seq.Seq where
    singleton = Seq.singleton
    rev = Seq.reverse
    monoid = Dict

dragonCurveSeq :: [Bool] -> [Bool]
dragonCurveSeq = toList . dragonAlgo (mempty :: Seq.Seq Bool) . fromList


data WithRev f a = WithRev { drForward :: f a, drReverse :: f a }
    deriving (Functor)

instance Foldable f => Foldable (WithRev f) where
    foldMap f (WithRev a _) = foldMap f a

instance (Monoid (f a)) => Monoid (WithRev f a) where
    mempty = WithRev mempty mempty
    (WithRev a b) `mappend` (WithRev a' b') = WithRev (a <> a') (b' <> b)

instance DragonList f => DragonList (WithRev f) where
    singleton x = WithRev (singleton x) (singleton x)
    rev (WithRev a b) = WithRev b a
    monoid = helper monoid
        where
        helper :: Dict (Monoid (f a)) -> Dict (Monoid (WithRev f a))
        helper Dict = Dict


instance DragonList DList.DList where
    singleton = DList.singleton
    rev = error "DList rev"
    monoid = Dict

dragonCurveWithRevDList :: [Bool] -> [Bool]
dragonCurveWithRevDList = toList . dragonAlgo (mempty :: WithRev DList.DList Bool) . fromList

checksum1 :: [Bool] -> ([Bool], Bool)
checksum1 [] = ([], False)
checksum1 [x] = ([x], True)
checksum1 (x:y:xs) = ((x == y) : rest, stop)
    where (rest, stop) = checksum1 xs

checksum :: [Bool] -> [Bool]
checksum xs
    | stop = xs
    | otherwise = checksum ck
    where (ck, stop) = checksum1 xs

fromBitStr :: String -> [Bool]
fromBitStr = map fromBit
    where
    fromBit '0' = False
    fromBit '1' = True
    fromBit c = error $ "not a bit: " ++ show c

toBitStr :: [Bool] -> String
toBitStr = map toBit
    where
    toBit False = '0'
    toBit True = '1'

main = print . checksum . take (2^20*5) $ dragonCurveWithRevDList []