repfunc.hs

-- https://chrispenner.ca/posts/representable-discrimination

{-# LANGUAGE TypeFamilies, FlexibleContexts, DeriveFunctor #-}

import Data.Monoid (Sum(..))

class Representable f where
   type Rep f :: *
   tabulate :: (Rep f -> a) -> f a
   index    :: f a -> Rep f -> a

-- Here's our newtype with a Monoid over Representables
newtype MRep r a = MRep {unMRep ::r a}
  deriving (Show, Eq, Functor)

instance (Monoid a, Representable r) => Semigroup (MRep r a) where
    (MRep r1) <> (MRep r2) = MRep $ tabulate $ index r1 <> index r2

instance (Monoid a, Representable r) => Monoid (MRep r a) where
    mempty = MRep $ tabulate (const mempty)


repSort :: (Representable r, Monoid m, Foldable f, Eq (Rep r)) => (a -> Rep r) -> (a -> m) -> f a -> r m
repSort indOf toM = unMRep . foldMap (MRep . tabulate . desc)
  where
    -- desc takes an 'a' from the foldable and returns a descriptor function which can be passed to 'tabulate',
    -- The descriptor just returns mempty unless we're on the slot where the 'a's result is supposed to end up.
    --desc :: a -> Rep r -> m
    desc a i
      | i == indOf a = toM a
      | otherwise = mempty

data Pair a = Pair a a
    deriving (Show, Eq, Functor)

instance Representable Pair where
    type Rep Pair = Bool
    tabulate desc = Pair (desc True) (desc False)
    index (Pair a _) True = a
    index (Pair _ a) False = a

sortedInts :: Pair [Int]
sortedInts = repSort odd (:[]) [1..10]

oddEvenSums :: Pair (Sum Int)
oddEvenSums = repSort odd Sum [1..10]

--------------------

data Triple a = Triple a a a

data OneTwoThree = One | Two | Three

instance Representable Triple where
    type Rep Triple = OneTwoThree
    tabulate desc = Triple (desc One) (desc Two) (desc Three)
    index (Triple a _ _ ) One = a
    index (Triple _ b _ ) Two = b
    index (Triple _ _ c ) Three = c

-----------------------

-- https://bartoszmilewski.com/2015/07/29/representable-functors/
data Stream x = Cons x (Stream x)

instance Representable Stream where
    type Rep Stream = Int
    tabulate f = Cons (f 0) (tabulate (f . (+1)))
    index (Cons b bs) n = if n == 0 then b else index bs (n - 1)


byLength :: Stream [String]
byLength = repSort length (:[]) ["javascript", "purescript", "haskell", "python"]


byFirstChar :: Stream [String]
byFirstChar = repSort (fromEnum . head) (:[]) ["cats", "antelope", "crabs", "aardvarks"]

--------------

data Tree a = Node a (Tree a) (Tree a) 

--data TreeIndex = TreeIndex [Bool]

instance Representable Tree where
  type Rep Tree = [Bool]
  index (Node a _ _) [] = a
  index (Node _ l r) (b:bs) = index (if b then l else r) bs
  tabulate desc = Node (desc []) (tabulate (desc . (True:))) (tabulate (desc . (False:))) 


descimpl :: [Bool] -> Bool
descimpl = even . length . filter (\b -> b == True)

btree :: Tree Bool
btree = tabulate descimpl 

printtree :: Show a => Tree a -> String
printtree t = printtree' t 0
  where
    printtree' :: Show a => Tree a -> Int -> String
    printtree' (Node n l r) d = 
      let 
        s1 = take (2*d) (repeat ' ') ++ show n ++ "\n"
        s2 = printtree' l (d+1)
        s3 = printtree' r (d+1)
      in
        if d >= 4 then
          s1
        else 
          s1 ++ s2 ++ s3
    

Btw you can deriving (Semigroup, Monoid) via Ap (Co r) a where Co is from https://hackage.haskell.org/package/adjunctions-4.4/docs/Data-Functor-Rep.html

@Icelandjack interesting! thanks