R(n)列挙

て日々(6月1日)にあった問題.すこし考えたんだけど綺麗には書けず.ぐちゃぐちゃ.Natクラスのメソッドにしたり,禁断の unsafeCoerce を使ってしまった.

R(5)はちょっと長すぎるのでR(3)とR(4)を表示.

ghci> pprR three
"{0,{0},{{0}},{0,{0}}}"
ghci> pprR four
"{0,{0},{{0}},{0,{0}}
,{{{0}}},{0,{{0}}},{{0},{{0}}},{0,{0},{{0}}}
,{{0,{0}}},{0,{0,{0}}},{{0},{0,{0}}},{0,{0},{0,{0}}}
,{{{0}},{0,{0}}},{0,{{0}},{0,{0}}},{{0},{{0}},{0,{0}}},{0,{0},{{0}},{0,{0}}}}"

コードは以下のとおり.美しい書き方ぜひ教えてください.

{-# LANGUAGE TypeFamilies
            ,FlexibleContexts
            #-}

import Unsafe.Coerce

type family PSet n :: *
type instance PSet Zero     = [Zero]
type instance PSet (Succ n) = [PSet n]

class Nat n where
  type Pre  n :: *
  pre   :: n -> Pre n
  pre   =  undefined
  rset  :: n -> PSet n
  pprR  :: Show (PSet n) => n -> String
  pprR  =  pprPSet . show . rset

data Zero
data Succ n

instance Nat Zero where
  type Pre  Zero = Zero
  rset  = const []

instance Nat n => Nat (Succ n) where
  type Pre  (Succ n) = n
  rset = unsafeCoerce . pset . unsafeCoerce . rset . pre

instance Show Zero
instance Nat n => Show (Succ n)

type One   = Succ Zero
type Two   = Succ One
type Three = Succ Two
type Four  = Succ Three
type Five  = Succ Four

zero  :: Zero
one   :: One
two   :: Two
three :: Three
four  :: Four
five  :: Five
zero = undefined
one  = undefined
two  = undefined
three= undefined
four = undefined
five = undefined

pset :: [a] -> [[a]]
pset []     = [[]]
pset (x:xs) = xss /\/ map (x:) xss 
  where 
    xss = pset xs
    [] /\/ ys = ys
    (x:xs) /\/ ys = x : (ys /\/ xs)

pprPSet :: String -> String
pprPSet "" = ""
pprPSet ('[':']':s) = '0':pprPSet s
pprPSet ('[':s)     = '{':pprPSet s
pprPSet (']':s)     = '}':pprPSet s
pprPSet (c  :s)     = c  :pprPSet s

1to100penさんのヒントにより書いたもの

data List = Nil | List ::: List を使った.
Python 読めないので,Pythonの解と同じかどうかは良くわからない.

data List = Nil | List ::: List

r :: Int -> List
r 0 = Nil
r n = powerset (r (n-1))

powerset :: List -> List
powerset Nil         = Nil ::: Nil
powerset (xs ::: ys) = yss >< mapL (xs :::) yss where yss = powerset ys

mapL :: (List -> List) -> List -> List
mapL f Nil = Nil
mapL f (h ::: t) = f h ::: mapL f t

infixr 5 ><, :::

(><) :: List -> List -> List
(xs ::: ys) >< zs = xs ::: (zs >< ys)
Nil         >< zs = zs

instance Show List where
  show = pprL

pprL :: List -> String
pprL = flip pprh' ""
  where
    pprh' Nil = zr
    pprh' (h ::: t) = ob . nl . sp . pprh h . nl . pprt' t . cb
    pprh Nil = zr
    pprh (h ::: t) = ob . pprh h . pprt t . cb
    pprt' Nil = id
    pprt' (h ::: t) = cm . pprh h . nl . pprt' t
    pprt Nil = id
    pprt (h ::: t) = cm . pprh h . pprt t
    nl = ('\n':); ob = ('{':); cb = ('}':); cm = (',':); zr = ('0':); sp = (' ':)