[Haskell-cafe] A practical Haskell puzzle

[Brandon Moore]

> From: Yitzchak Gale <gale at sefer.org>

> To: haskell-cafe at haskell.org
> Cc: Heinrich Apfelmus <apfelmus at quantentunnel.de>; Lennart Augustsson 
><lennart.augustsson at gmail.com>
> Sent: Wed, March 2, 2011 9:45:15 AM
> Subject: Re: [Haskell-cafe] A practical Haskell puzzle
> 
> Thanks to everyone for the nice solutions to this puzzle,
> here and on  reddit:
> 
> http://www.reddit.com/r/haskell/comments/fu6el/a_practical_haskell_puzzle/

It seems nobody has provided a simple H98 solution.

I misread your question as asking for the composition of
arbitrary type-compatible subsets of the layers, like

> runCompose [1,7,4,3] input 

if it happens fun1 . fun7 . fun4 . fun3 is well typed.
This is not easy to do without Dynamic.

Now I see you just want contiguous layers, which
is easy enough in H98.

This code produces and uses a table of all
allowed combinations. I think this makes it easier
to understand why the code works (and is H98).
It's just as easy to make a direct version that
produces one requested composition in linear time,
so I haven't worried whether lazy evaluation of this
table works nicely.

\begin{code}
runLayers :: Int -> Int -> String -> String
runLayers n m = (table !! (n-1)) !! (m-n)

table :: [[String -> String]]
table = close (extend fun1 (extend fun2 (extend fun3 (extend fun4 seed))))
\end{code}

Here are some examples with this sequence of layers and transformations
(exact type definition and function definitions at the end of the message).

Layer1: (Int,Int) --(uncurry(+))-->
Layer2: Int  --(\x -> if even x then Left x else Right x)-->
Layer3: Either Int Int  --(either (2*) negate)-->
Layer4: Int --(`quotRem`14)-->
Layer5: (Int,Int)

*Main> read (runLayers 2 4 (show (Layer2 "X" 12))) :: Layer4
Layer4 "fun3(fun2(X))" 24

*Main> read (runLayers 4 5 (show (Layer4 "Y" 15))) :: Layer5
Layer5 "fun4(Y)" (1,1)

*Main> read (runLayers 1 5 (show (Layer1 "fullStack" (5,6)))) :: Layer5
Layer5 "fun4(fun3(fun2(fun1(fullStack))))" (0,-11)

The table also include trivial slices, which might be useful to
check the serialization:

*Main> read (runLayers 3 3 "(Layer3   \"X\" (Left    (12)))") :: Layer3
Layer3 "X" (Left 12)

The key observation is that if all compositions of functions are
followed by the appropriate initialization function, then all the
functions starting at the same layer have the same type.

With four layers,

   show .
   show . fun34
   show . fun45 . fun34

all have type Layer3 -> String

The table construction uses a type

\begin{code}
data Layered a = Layered [a -> String] [[String -> String]]
\end{code}

which stores all sequences beginning at layer "a" with the
uniform type [a -> String], and already has all strictly later
sequences in the table [[String->String]].

A partial sequences can be extended by precomposing another function,
or converted to the unform type by precomposing the deserialization
function. To ensure only one type parameter is exposed at a time,
the extend function combines both steps.

\begin{code}
extend :: (Show a, Read b) => (a -> b) -> Layered b -> Layered a
extend f (Layered gs tails) =
  Layered (show:[g . f | g <- gs]) ([g . read | g <- gs]:tails)
\end{code}

The final step just closes partial sequences to produce
one table, and the seed is a trivial table.

\begin{code}
close :: (Read a) => Layered a -> [[String -> String]]
close (Layered fs tails) = [f . read | f <- fs]:tails

seed :: (Show a) => Layered a
seed = Layered [show] []
\end{code}

Exact definition of the layer types.

\begin{code}
data Layer1 = Layer1 String (Int,Int)  deriving (Read, Show)
data Layer2 = Layer2 String Int        deriving (Read, Show)
data Layer3 = Layer3 String (Either Int Int) deriving (Read, Show)
data Layer4 = Layer4 String Int        deriving (Read, Show)
data Layer5 = Layer5 String (Int,Int)  deriving (Read, Show)
\end{code}

\begin{code}
fun1 (Layer1 s x) = Layer2 ("fun1("++s++")") (uncurry (+) x)
fun2 (Layer2 s x) = Layer3 ("fun2("++s++")") (if even x then Left x else Right 
x)
fun3 (Layer3 s x) = Layer4 ("fun3("++s++")") (either (2*) negate x)
fun4 (Layer4 s x) = Layer5 ("fun4("++s++")") (x `quotRem` 14)
\end{code}