Thank you for this update. Now that problwm and solution fit, I can understand whats going on in your code :]

I was scared of a hard combinatorial puzzle day, but this was a breeze.

{-# LANGUAGE TupleSections #-}
module Main (main) where
import Control.Monad ((<$!>))
import qualified Data.Text.IO as TextIO
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.IntSet as IntSet
import Control.Arrow ((>>>))
import qualified Data.List as List
import qualified Data.IntMap as IntMap

part1 :: [IntSet.Key] -> IntSet.Key
part1 = IntSet.fromList
  >>> IntSet.foldl (+) 0

part2 :: [IntSet.Key] -> IntSet.Key
part2 = IntSet.fromList
  >>> IntSet.toAscList
  >>> take 20
  >>> sum

part3 :: [IntMap.Key] -> Int
part3 = List.map (, 1)
  >>> IntMap.fromListWith (+)
  >>> IntMap.toList
  >>> List.map snd
  >>> maximum

main :: IO ()
main = do
  sizes <- map (read . Text.unpack) . Text.split (== ',') <$!> TextIO.getLine
  print $ part1 sizes
  print $ part2 sizes
  print $ part3 sizes

I struggled for a long time because I had nearly the correct results. I had to switch div with quot.

This puzzle was fun. If you have a visualization, it’s even cooler. (It’s a fractal)

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS_GHC -Wall #-}
module Main (main) where
import Text.Read (ReadPrec, Read (readPrec))
import Data.Functor ((<&>))
import Data.Text (pattern (:<), Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as TextIO
import Control.Monad ((<$!>))
import Control.Arrow ((<<<))

newtype Complex = Complex (Int, Int)

instance Read Complex where
  readPrec :: ReadPrec Complex
  readPrec = readPrec <&> \case
    [a, b] -> Complex (a, b)
    _ -> undefined

instance Show Complex where
  show :: Complex -> String
  show (Complex (a, b))= show [a, b]

readAEquals :: Text -> Complex
readAEquals ('A' :< '=':< rest) = read $ Text.unpack rest
readAEquals _ = undefined


-- >>> Complex (1, 1) `add` Complex (2, 2)
-- [3,3]

add :: Complex -> Complex -> Complex
(Complex (x1, y1)) `add` (Complex (x2, y2)) = Complex (x1 + x2, y1 + y2)

-- >>> Complex (2, 5) `times` Complex (5, 7)
-- [-25,-11]

times :: Complex -> Complex -> Complex
(Complex (x1, y1)) `times` (Complex (x2, y2)) = Complex (x1 * x2 - y1 * y2, x1 * y2 + x2 * y1)

dividedBy :: Complex -> Complex -> Complex
(Complex (x1, y1)) `dividedBy` (Complex (x2, y2)) = Complex (x1 `quot` x2, y1 `quot` y2)

step :: Complex -> Complex -> Complex
step a r = let
 r1 = r `times` r
 r2 = r1 `dividedBy` Complex (10, 10)
 r3 = r2 `add` a
 in r3

zero :: Complex
zero = Complex (0, 0)

part1 :: Complex -> Complex
part1 a = iterate (step a) (Complex (0, 0)) !! 3

shouldBeEngraved :: Complex -> Bool
shouldBeEngraved complexPoint = let

  cycleStep :: Complex -> Complex -> Complex
  cycleStep point r = let
    r2 = r `times` r
    r3 = r2 `dividedBy` Complex (100000, 100000)
    in point `add` r3

  inRange x = x <= 1000000 && x >= -1000000


  in all (\ (Complex (x, y)) -> inRange x && inRange y)
    <<< take 101
    <<< iterate (cycleStep complexPoint)
    $ zero

-- >>> shouldBeEngraved $ Complex (35630,-64880)
-- True
-- >>> shouldBeEngraved $ Complex (35460, -64910)
-- False
-- >>> shouldBeEngraved $ Complex (35630, -64830)
-- False

part2 :: Complex -> Int
part2 (Complex (xA, yA)) = let

    xB = xA + 1000
    yB = yA + 1000

  in length . filter shouldBeEngraved $ do
    x <- [xA, xA+10.. xB]
    y <- [yA, yA+10.. yB]
    pure $ Complex (x, y)

part3 :: Complex -> Int
part3 (Complex (xA, yA)) = length . filter shouldBeEngraved $ do
  x <- [xA..xA+1000]
  y <- [yA..yA+1000]
  pure $ Complex (x, y)

-- >>> [0, 10..100]
-- [0,10,20,30,40,50,60,70,80,90,100]

main :: IO ()
main = do
  a <- readAEquals <$!> TextIO.getContents
  print $ part1 a
  print $ part2 a
  print $ part3 a

My girlfriend is learning python, we are taking on the challenges together, today I may upload her solution:

A=[-3344,68783]
R = [0, 0]
B= [A[0]+1000, A[1]+1000]
pointsengraved = 0
cycleright = 0


for i in range(A[1], B[1]+1):
    for j in range(A[0], B[0]+1):
        for k in range(100):
            R = [int(R[0] * R[0] - R[1] * R[1]), int(R[0] * R[1] + R[1] * R[0])]
            R = [int(R[0] / 100000), int(R[1] / 100000)]
            R = [int(R[0] + j), int(R[1] + i)]
            if -1000000>R[0] or R[0]>1000000 or -1000000>R[1] or R[1]>1000000:
                #print(".", end="")
                break
            cycleright += 1
        if cycleright == 100:
            pointsengraved += 1
            #print("+", end="")
        cycleright = 0
        R = [0, 0]
    #print()

print(pointsengraved)

The commented out print statements produce an ascii map of the set, which can be cool to view at the right font size.

I’m very curious about F# since I’ve never used it or seen it anywhere before but I’m afraid I’m too tired to read it right now. Thank you for posting, I hope I’ll remember to come back tomorrow.

I coded this along with my girlfriend who’s learning python, but not motivated to share her solution. The program reads from stdin, because I usually invoke it like so: runhaskell Main.hs < input or runhaskell Main.hs < example. I think this is quite handy because I don’t have to change the source code to check the example input again.

I struggled with Part 3, where I suddenly forgot I could’ve simply used mod, which I ended up doing anyway. I immediately recognized that Part 3 needs Mutable Arrays if I care to avoid Index hell, which is not what I wanted to with Haskell but oh well.

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE PatternSynonyms #-}
module Main (main) where

import qualified Data.Text as Text
import qualified Data.Text.IO as TextIO
import Control.Monad ((<$!>), forM_)
import Data.Text (Text, pattern (:<))
import qualified Data.List as List
import qualified Data.Array.MArray as MutableArray
import Control.Monad.ST (runST, ST)
import Data.Array.ST (STArray)

commaSepLine :: IO [Text.Text]
commaSepLine = Text.split (== ',') <$!> TextIO.getLine

readInstruction :: Text -> Int
readInstruction ('R' :< n) = read . Text.unpack $ n
readInstruction ('L' :< n) = negate . read . Text.unpack $ n
readInstruction _ = undefined

myName :: (Foldable t, Ord b, Enum b, Num b) => b -> t b -> b
myName maxPosition = List.foldl' (\ pos offset -> min (pred maxPosition) . max 0 $ pos + offset) 0

parentName1 :: [Int] -> Int
parentName1 = List.sum

newSTArray :: [e] -> ST s (STArray s Int e)
newSTArray xs = MutableArray.newListArray (0, length xs - 1) xs

swap :: (MutableArray.MArray a e m, MutableArray.Ix i) => a i e -> i -> i -> m ()
swap array i0 i1 = do
  e0 <- MutableArray.readArray array i0
  e1 <- MutableArray.readArray array i1
  MutableArray.writeArray array i0 e1
  MutableArray.writeArray array i1 e0

parentName2 :: [Text] -> [Int] -> Text
parentName2 nameList instructions = runST $ do
  names <- newSTArray nameList
  arrayLength <- succ . snd <$> MutableArray.getBounds names
  forM_ instructions $ \ offset -> do
    let arrayOffset = offset `mod` arrayLength
    swap names 0 arrayOffset
  MutableArray.readArray names 0

main :: IO ()
main = do
  names <- commaSepLine
  _ <- TextIO.getLine
  instructions <- fmap readInstruction <$> commaSepLine

  let namesLength = length names
  print $ names !! myName namesLength instructions
  print . (names !!) . (`mod` namesLength) $ parentName1 instructions
  print $ parentName2 names instructions