Alpen.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}

import Data.Functor.Foldable
import Data.List

-- * Abstract Alpine Architecture

data Nat = S Nat | Z

class Alpine (a :: Nat -> *) where
  plateau :: a n -> a n
  ascend  :: a (S n) -> a n
  descend :: a n -> a (S n)
  end     :: a Z

class Generate (n :: Nat) where
  generate' :: Alpine a => Int -> [a n]

instance Generate Z where
  generate' 0 = [ end ]
  generate' n = map ascend (generate' $ n - 1) ++ map plateau (generate' $ n - 1)

instance Generate n => Generate (S n) where
  generate' 0 =    []
  generate' n =    map ascend (generate' $ n - 1)
               ++ map plateau (generate' $ n - 1)
               ++ map descend (generate' $ n - 1)

generate :: Alpine a => Int -> [a Z]
generate = generate'

-- * GADT Implementation

data Mountains :: Nat -> * where
  Plateau :: Mountains n -> Mountains n
  Ascend  :: Mountains (S n) -> Mountains n
  Descend :: Mountains n -> Mountains (S n)
  End     :: Mountains Z

instance Alpine Mountains where
  plateau = Plateau
  ascend  = Ascend
  descend = Descend
  end     = End

generalize :: Alpine a => Mountains n -> a n
generalize = \case
  Plateau xs -> plateau (generalize xs)
  Ascend  xs -> ascend (generalize xs)
  Descend xs -> descend (generalize xs)
  End        -> end

-- * Tree Implementation

data HillF a
  = PlateauTF a
  | HillTF    a a
  | EndTF
  deriving (Show, Functor)

pattern PlateauT x = Fix (PlateauTF x)
pattern HillT x y  = Fix (HillTF x y)
pattern EndT       = Fix (EndTF)

type HillTree = Fix HillF

data Stack (n :: Nat) a where
  SNil  :: Stack Z a
  SCons :: a -> Stack n a -> Stack (S n) a

newtype HT (n :: Nat) = HT { unHT :: Stack (S n) HillTree }

stackDip :: (a -> a) -> Stack (S n) a -> Stack (S n) a
stackDip f (SCons x xs) = SCons (f x) xs

stackApply :: (a -> a -> a) -> Stack (S (S n)) a -> Stack (S n) a
stackApply f (SCons x (SCons y ys)) = SCons (f x y) ys

instance Alpine HT where
  plateau (HT st) = HT $ stackDip PlateauT st
  ascend  (HT st) = HT $ stackApply HillT st
  descend (HT st) = HT $ SCons EndT st
  end             = HT $ SCons EndT SNil

runHT :: HT Z -> HillTree
runHT (HT (SCons x SNil)) = x

flatten :: Alpine a => HillTree -> a Z
flatten = flip flatten' end

flatten' :: Alpine a => HillTree -> a n -> a n
flatten' t end' = case t of
    PlateauT xs -> plateau (flatten' xs end')
    EndT        -> end'
    HillT xs ys -> ascend $ flatten' xs $ descend $ flatten' ys end'

-- * Height-Map Implementation

newtype HMap (n :: Nat) = HMap { unHMap' :: [Int] }

unHMap :: HMap Z -> [Int]
unHMap = unHMap'

instance Alpine HMap where
  plateau = HMap . (0:) . unHMap'
  ascend  = HMap . (0:) . map (+1) . unHMap'
  descend = HMap . (0:) . map (subtract 1) . unHMap'
  end     = HMap [0]

-- * Test Program

main = do
  putStrLn "Using `Alpine HMap` instance"
  mapM_ print $ sort $ map unHMap                $ generate 4
  putStrLn ""
  putStrLn "Using `Alpine Mountains` instance"
  mapM_ print $ sort $ map (unHMap . generalize) $ generate 4
  putStrLn ""
  putStrLn "Using `Alpine HT` instance"
  mapM_ print $ sort $ map (unHMap . flatten . runHT) $ generate 4