# Beautiful functional programming

And how about a knot-tying solution!
Use laziness to pass the solution as an input to the function that calculates the solution.
Still grouping on section titles to keep things simple.

1 Like

A solution with list recursion and consing.
Resursion.hs

``````-- data declarations, setup elided....

updateSections :: [Section] -> Int -> Int -> [Section]
updateSections [] _ _ = []
s { position = sc', lessons = ls }: updateSections ss sc' (lessonPosition (last ls))
where sc' = sc + 1
ls = updateLessons (lessons s) (if resetLessonPosition s == True then 0 else lc)

updateLessons :: [Lesson] -> Int -> [Lesson]
updateLessons [] _ = []
updateLessons (l:ls) lc = l { lessonPosition = lc' }: updateLessons ls lc'
where lc' = lc + 1

solve :: IO ()
solve = print \$ updateSections sections 0 0
``````
2 Likes

I maintain that any solution that uses aesonās `fromJSON` to parse to nice types is still operating on a key-value structure!

``````positionLesson :: Lesson -> Int -> PositionedLesson
positionLesson Lesson{..} position = PositionedLesson{..}

positionSection :: Section a -> Int -> PositionedSection a
positionSection Section{..} position = PositionedSection{..}

challenge :: Value -> Value
challenge val = case fromJSON val of
Success section -> toJSON \$ setPositions section
Error _ -> error "Fail to parse JSON as Section"

setPositions :: [Section Lesson] -> [PositionedSection PositionedLesson]
setPositions =
coerce (imap' @(Compose [] PositionedSection) positionLesson)
<=< splitWhen (.reset_lesson_position)
. imap' positionSection

imap' :: (Traversable t) => (a -> Int -> b) -> t a -> t b
imap' f = flip evalState 1 . traverse (assignPos . f)

assignPos :: (Int -> b) -> State Int b
assignPos f = f <\$> get <* modify' (+ 1)
``````

Oh whatās that? You want to run this cute adorable bit of code yourself?
This smaaalll bit of setup codeā¦

``````{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoFieldSelectors #-}

module MyLib where

import Data.Aeson (FromJSON, Result (..), ToJSON (toJSON), Value, fromJSON, decode)
import Data.Coerce (coerce)
import Data.Functor.Compose (Compose (Compose))
import Data.Text (Text)
import GHC.Generics (
Generic,
Generic1,
Generically (..),
)
import Data.Aeson.Encode.Pretty (encodePretty)
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.List.Split (splitWhen)

getData :: IO BS.ByteString

test :: IO ()
test = BS.putStrLn . encodePretty . maybe (error "Bad JSON") challenge . decode =<< getData

data Section a = Section
{ title :: Text
, reset_lesson_position :: Bool
, lessons :: [a]
}
deriving (Generic, Generic1, Functor, Foldable, Traversable)

deriving via Generically (Section a) instance (ToJSON a) => ToJSON (Section a)
deriving via Generically (Section a) instance (FromJSON a) => FromJSON (Section a)

data PositionedSection a = PositionedSection
{ title :: Text
, reset_lesson_position :: Bool
, lessons :: [a]
, position :: Int
}
deriving (Generic, Generic1, Functor, Foldable, Traversable)

deriving via Generically (PositionedSection a) instance (ToJSON a) => ToJSON (PositionedSection a)
deriving via Generically (PositionedSection a) instance (FromJSON a) => FromJSON (PositionedSection a)

data Lesson = Lesson
{ name :: Text
}
deriving (Generic)

deriving via Generically Lesson instance ToJSON Lesson
deriving via Generically Lesson instance FromJSON Lesson

data PositionedLesson = PositionedLesson
{ name :: Text
, position :: Int
}
deriving (Generic)

deriving via Generically PositionedLesson instance ToJSON PositionedLesson
deriving via Generically PositionedLesson instance FromJSON PositionedLesson

``````
1 Like

A solution decoupling position generation and the updating of the sections

`````` updatePositions sections (zip [1..] \$ lessonPosititions sections)
``````

with

``````-- | Computes the lesson positions as a [[Int]]
lessonPosititions :: [Section a] -> [[Int]]
lessonPosititions sections =
concatMap (flip reStructure [1..] . map lessons)  \$ breakOn resetLessonPosition sections

-- | Update the a list of section with the given section and lesson position.
updatePositions :: [Section a] -> [(Int, [Int])] -> [Section Int]
updatePositions =
zipWith (\s (sp, poss) -> s {sposition = sp
, lessons = zipWith (\l p -> l { lposition = p})
(lessons s)
poss
}
)
``````

and the need of generic helpers which could be in Base

``````-- | Break a a list into nested lists
-- by copying the structure of a neste list
-- > reStructure ["abc", "d", "ef"] [1..]
--    [[1,2,3], [4], [5,6]]
reStructure :: [[a]] -> [b] -> [[b]]
reStructure [] _ = []
reStructure _ [] = []
reStructure ([]:xss) ys = []: reStructure xss ys
reStructure ((x:xs):xss) (y:ys) =
case reStructure (xs:xss) ys of
[] -> [[y]]
(ys':yss') -> (y:ys'):yss'

breakOn :: (a -> Bool) -> [a] -> [[a]]
breakOn f = groupBy (const \$ not . f)

``````

`lessonPositions` solves the real problem : finding the position number for a list of section.
Itās a pretty straight forward one liner.
The `updatePositions` is where Haskell doesnāt shine, updating nested data.
Still straightforward though.
(full code from @tomjaguarpaw gist).

1 Like

This version is using Aesonās Value type (JSON value, basically, over a treemap datatype), for a high fidelity rendering of the problem. This is also a pure zip-based solution using either the KeyMap interface in Aeson or through lens; no exec-state in sight here.

Which actually brings to mind another question: If you want to work with mutable objects holding dynamic data (i.e, some kind of treemap or hashmap), what is the canonical way to do so? You have Hashmap, Treemap, Keymap, EDN (from Clojure) libraries for the data structure. Of course, youāll need either lens or optics to manipulate them efficiently, and I guess, even more canonically, you should cast them via aeson or other parser into a native Haskell ADT.

``````{- cabal:
build-depends: base, lens, lens-aeson, vector, aeson, aeson-pretty, bytestring
-}

import Data.Aeson
import qualified Data.Aeson.KeyMap as KM
import Data.Aeson.QQ.Simple
import Data.Function ((&))
import qualified Data.Vector as V
import Control.Arrow
import qualified Data.List as L
import Data.Maybe (fromMaybe)
import Data.Foldable (traverse_)
import Data.Aeson.Encode.Pretty
import Data.ByteString.Lazy as BSL
import Data.String (fromString)

import Control.Lens
import Data.Aeson.Lens

samples :: Value
samples = [aesonQQ|[
{
"title": "Getting started",
"reset_lesson_position": false,
"lessons": [
{"name": "Welcome"},
{"name": "Installation"}
]
},

{
"title": "Basic operator",
"reset_lesson_position": false,
"lessons": [
{"name": "Multiplication / Division"}
]
},

{
"reset_lesson_position": true,
"lessons": [
{"name": "Mutability"},
{"name": "Immutability"}
]
}
]|]

fixedSamples :: Value
fixedSamples = [aesonQQ|[
{
"title": "Getting started",
"reset_lesson_position": false,
"position": 1,
"lessons": [
{"name": "Welcome", "position": 1},
{"name": "Installation", "position": 2}
]
},

{
"title": "Basic operator",
"reset_lesson_position": false,
"position": 2,
"lessons": [
{"name": "Addition / Subtraction", "position": 3},
{"name": "Multiplication / Division", "position": 4}
]
},

{
"reset_lesson_position": true,
"position": 3,
"lessons": [
{"name": "Mutability", "position": 1},
{"name": "Immutability", "position": 2}
]
}
]|]

main :: IO ()
main = traverse_ BSL.putStr
[ fromString . show \$ hiJose samples == fixedSamples
, "\n\n\n"
, encodePretty \$ hiJose samples
, "\n\n\n"
, encodePretty fixedSamples
, "\n\n\n"
, fromString . show \$ hiYosef samples == fixedSamples
, "\n\n\n"
, encodePretty \$ hiYosef samples
, "\n"
]

hiJose :: Value -> Value
hiJose (Array innerArray) = Array . V.fromList
\$ L.zipWith (\(Object keymap) count -> KM.insert "position" (Number (fromIntegral count)) keymap) (V.toList innerArray) [1..]
& L.groupBy (\_ b -> not . (\(Bool a) -> a) . fromMaybe (Bool False) \$ b KM.!? "reset_lesson_position")
& fmap (zipAcross [1..] . fmap (id &&& maybe V.empty (\(Array a) -> a) . KM.lookup "lessons") )
& L.concat
& fmap makeAndAppendNewLessonField
where
zipAcross a [] = []
zipAcross a ((keymap, lessons):cont) =
let (segment, remainder) = L.splitAt (V.length lessons) a in
(keymap, L.zip (V.toList lessons) segment) : zipAcross remainder cont

makeAndAppendNewLessonField (keymap, vecOfLessonsKey) = Object \$
KM.insert "lessons" newLessonField keymap
where
newLessonField = Array . V.fromList
\$ fmap makeNewLessonField vecOfLessonsKey
makeNewLessonField (Object lesson, number) = Object \$ KM.insert "position" (Number \$ fromIntegral number) lesson

hiYosef :: Value -> Value -- Get the joke? Well, it wasn't funny anyways.
hiYosef = partsOf (values . atKey "position") .~ numbering
>>> V.fromList . toListOf values
>>> V.groupBy (\_ b -> not . fromMaybe False \$ b ^? key "reset_lesson_position" . _Bool)
>>> fmap (partsOf (traversed . key "lessons" . values . atKey "position") .~ numbering)
>>> Array . V.concat
where
numbering = Just . Number . fromIntegral <\$> [1..]
``````

The ultimate lens version is still disappointing, is there a way to get lens to respect the bool during a traversal? That could easily save on a ton of code hereā¦

If you program with cartesian closed categories in mind, then itās functional.
If you rely on separation logic, then it is imperative.
Easy!

2 Likes

Can you say something about separation logic and how it connects to the intuitive understanding of āimperativeā?

What does

program with cartesian closed categories in mind

(emphasis added by me) even mean? Also why does for FP is enough to have CCC in mind but for imperative programming you have to rely on separation logic?

That seems of fairly marginal utility compared to `-XRecordWildCards`.

Because `Hask` isnāt a true category and youād get ridiculed for talking about it like that