The description of the problem itself sounds utterly imperative. There’s even a literal imperative in the input schema: reset_lesson_position
.
Perhaps the more interesting question is can we rephrase the problem in declarative terms?
For one, I’d remove the reset_lesson_position
and instead make the input a list of lists where the sections are grouped such that inside each group the lesson position starts from 1:
g :: [(Bool, a)] -> [[a]]
g = map (map snd) . groupBy (\_ (x,_) -> not x)
A simplified variant of the problem is perhaps this:
Define f :: [[a]] -> [[(Int, a)]]
such that for all a :: Type
and x :: [[a]]
we have map fst (concat (f x)) == [1 .. length x]
.
You can do this “the lens way” with a traversal which keeps track of state:
f :: [[a]] -> [[(Int, a)]]
f xs = evalState (traverse (traverse (\x -> do i <- get; put $! i + 1; pure (i, x))) xs) 1
You can even make it look much more imperative:
f :: [[a]] -> [[(Int, a)]]
f xss = (`evalState` 1) $
for xss $ \xs ->
for xs $ \x -> do
i <- get
put $! i + 1
pure (i, x)
Or alternatively, perhaps lesser known is “the attribute grammar way”, tying a recursive knot:
f :: [[a]] -> [[(Int, a)]]
f xss = yss where
(iss, yss) = unzip (zipWith zipKeep ([1..] : iss) xss)
zipKeep :: [a] -> [b] -> ([a], [(a, b)])
zipKeep xs [] = (xs, [])
zipKeep (x:xs) (y:ys) = let (xs', zs) = zipKeep xs ys in (xs', (x, y) : zs)
Here’s my full solution:
import Data.List (groupBy)
import Data.Bifunctor
data Section a b = Section String a [Lesson b] deriving Show
data Lesson a = Lesson String a deriving Show
f :: [Section a b] -> [Section a Int]
f xss = yss where
(iss, yss) = unzip (zipWith (\i (Section n v ls) -> second (Section n v) (zipKeep i ls)) ([1..] : iss) xss)
zipKeep :: [a] -> [Lesson b] -> ([a], [Lesson a])
zipKeep xs [] = (xs, [])
zipKeep (x:xs) (Lesson y _:ys) = let (xs', zs) = zipKeep xs ys in (xs', Lesson y x : zs)
g :: (b -> Bool) -> [Section b a] -> [[Section b a]]
g f = groupBy (\_ (Section _ x _) -> not (f x))
h :: [Section a b] -> [Section (Int, a) b]
h = zipWith (\i (Section n v ls) -> Section n (i, v) ls) [1..]
solve :: [Section Bool b] -> [Section Int Int]
solve = concat . map f . map (map (\(Section n (v, _) ls) -> Section n v ls)) . g snd . h
ghci> solve [Section "Getting Started" False [Lesson "Welcome" (), Lesson "Installation" ()], Section "Basic operator" False [Lesson "Addition / Subtraction" (), Lesson "Multiplication / Division" ()], Section "Advanced topics" True [Lesson "Mutability" (), Lesson "Immutability" ()]]
[Section "Getting Started" 1 [Lesson "Welcome" 1,Lesson "Installation" 2],Section "Basic operator" 2 [Lesson "Addition / Subtraction" 3,Lesson "Multiplication / Division" 4],Section "Advanced topics" 3 [Lesson "Mutability" 1,Lesson "Immutability" 2]]
I like that it decomposes the problem, but I don’t like that many components are not very reusable and there are some awkward reshaping parts necessary. I guess I’d need to grab some lenses or attribute grammars to really improve that.
Oh, you can introduce the reusable Flat
type and that makes it a lot prettier:
data Flat a = Flat Int [(a, Int)] deriving Functor
zipFlat :: (a -> b -> c) -> [a] -> Flat b -> Flat c
zipFlat f xs (Flat n ys) = Flat n (zipWith (\x' (y', z') -> (f x' y', z')) xs ys)
nest :: Flat a -> [[a]]
nest (Flat n xs) = replicate n [] ++ concatMap (\(x, n) -> [x] : replicate n []) xs
flat :: [[a]] -> Flat a
flat [] = Flat 0 []
flat xs = (\(x, y) -> Flat (length x) ((\(Flat _ x) -> x) (flat y))) (span null xs)
solve :: [((String, [String]), Bool)] -> [((String, Int), [(String, Int)])]
solve =
concatMap
( map (\((x,y):xs) -> (x, y: map snd xs))
. nest
. zipFlat (\i (x, y) -> (x, (y, i))) [1..]
. flat
. map sequence
)
. nest
. zipFlat (\i (x, y) -> ((x, i), y)) [1..]
. Flat 0
. map (second (\x -> if x then 1 else 0))
However, this still has a few bugs in it. Can you spot them?