ICFP Contest 2023 - JKRT report

{
  "room_width": 2000.0,
  "room_height": 5000.0,
  "stage_width": 1000.0,
  "stage_height": 200.0,
  "stage_bottom_left": [500.0, 0.0],
  "musicians": [0, 1, 0],
  "attendees": [
    {"x":  100.0, "y":  500.0, "tastes": [1000.0, -1000.0]},
    {"x":  200.0, "y": 1000.0, "tastes": [200.0, 200.0]},
    {"x": 1100.0, "y":  800.0, "tastes": [800.0, 1500.0]}
  ]
}

{
  "placements": [
    {"x": 590.0, "y": 10.0},
    {"x": 1100.0, "y": 100.0},
    {"x": 1100.0, "y": 150.0}
  ]
}

import Data.Vector.Unboxed qualified as UV

data Problem = Problem
    { problemStageHeight :: Int
    , problemStageWidth :: Int
    , problemMusicians :: UV.Vector Int
    , problemRoomHeight :: Int
    , problemRoomWidth :: Int
    , problemAttendees :: [Attendee]
    , problemStageBottomLeft :: (Int, Int)
    }

data Solution = Solution
    { solutionPlacements :: UV.Vector (Int, Int)
    }

drawProblem :: Problem -> Solution -> Picture
drawProblem problem solution = Pictures (room : stage : attendees)
  where
    room :: Picture
    room =
        Color red $
            rectangleWire
                (int2Float problem.problemRoomWidth)
                (int2Float problem.problemRoomHeight)

    toAbs :: Float -> Float -> Picture -> Picture
    toAbs x y = Translate (topX + x) (topY - y)
      where
        topX, topY :: Float
        topX = -1 * fromIntegral problem.problemRoomWidth / 2
        topY = fromIntegral problem.problemRoomHeight / 2

    stage :: Picture
    stage =
        toAbs
            (stageWidth / 2 + int2Float stageX)
            (stageHeight / 2 + int2Float stageY)
            $ Color orange
            $ Polygon
            $ rectanglePath stageWidth stageHeight
      where
        stageWidth = int2Float problem.problemStageWidth
        stageHeight = int2Float problem.problemStageHeight
        (stageX, stageY) = problem.problemStageBottomLeft

    attendees :: [Picture]
    attendees = map drawAttendee problem.problemAttendees

    drawAttendee :: Attendee -> Picture
    drawAttendee attendee =
        toAbs
            (fromIntegral attendee.attendeeX)
            (fromIntegral attendee.attendeeY)
            (Circle 3)

doRender :: Problem -> Solution -> IO ()
doRender problem solution = Gloss.display disp bg picture
  where
    disp = InWindow "ICFP Contest 2023" (winX, winY) (10, 10)
    bg = greyN 0.6
    picture = windowScale problem $ drawProblem problem solution

windowScale :: Problem -> Picture -> Picture
windowScale problem = Scale pscale pscale
  where
    pscale = fromIntegral scale * 0.98
    scale
        | problem.problemRoomHeight > problem.problemRoomWidth =
            winY `div` problem.problemRoomHeight
        | otherwise =
            winX `div` problem.problemRoomWidth

score :: Problem -> Solution -> Int
score problem solution =
    sum $ map (attendeeHappiness problem.problemMusicians solution) problem.problemAttendees

attendeeHappiness :: UV.Vector Int -> Solution -> Attendee -> Int
attendeeHappiness instruments solution attendee =
    UV.sum $ UV.imap musicianImpact solution.solutionPlacements
  where
    musicianImpact :: Int -> (Int, Int) -> Int
    musicianImpact musician placement
      | isBlocked = 0
      | otherwise =
        let (d,m) = (1_000_000 * taste) `divMod` distance
        in d + if m > 0 then 1 else 0
     where
       -- the musician's instrument
       instrument = instruments ! musician

       -- the attendee taste for this instrument
       taste = attendee.attendeeTastes ! instrument

       -- the distance between the attendee and the musician
       distance = calcDistance attendee placement

       -- is the musician blocked by another musician?
       isBlocked = UV.any checkBlocked solution.solutionPlacements
       checkBlocked :: (Int, Int) -> Bool
       checkBlocked otherPlacement = otherDistance < distance && isCrossed
          where
            otherDistance = calcDistance attendee otherPlacement
            isCrossed = lineCrossCircle attendee placement otherDistance 5 otherPlacement

calcDistance :: Attendee -> (Int, Int) -> Int
calcDistance attendee (px, py) = (attendee.attendeeX - px) ^ 2 + (attendee.attendeeY - py) ^ 2

-- | Check if the line between two points is blocked by a third point of a given radius (exclusive).
-- See: https://mathworld.wolfram.com/Circle-LineIntersection.html
lineCrossCircle :: Attendee -> (Int, Int) -> Int -> Int -> (Int, Int) -> Bool
lineCrossCircle attendee (mx, my) distance radius (px, py) = discriment > 0
  where
    (x1, y1) = (attendee.attendeeX - px, attendee.attendeeY - py)
    (x2, y2) = (mx - px, my - py)
    d = x1 * y2 - x2 * y1
    discriment = radius ^ 2 * distance - d ^ 2

-- | Arranging the musicians in a grid, this function returns all the available placements.
allGridPlacement :: (Int, Int) -> UV.Vector (Int, Int)
allGridPlacement (width, height) = UV.fromList $ go radius radius []
  where
    -- go takes the current (x, y) position, and the list of accumulated position
    go :: Int -> Int -> [(Int, Int)] -> [(Int, Int)]
    go x y !acc
        | -- there is room to fit another musician on this line, keep the y pos
          x + nextMusician < width = go (x + diameter) y newAcc
        | -- there is room to start another line, reset the x pos
          y + nextMusician < height = go radius (y + diameter) newAcc
        | -- this is the end
          otherwise = newAcc
      where
        -- store the current pos in the accumulator
        newAcc = (x, y) : acc

-- | Placement dimension: ( -r- o -r- )
radius, diameter :: Int
radius = 10
diameter = radius * 2

{- | nextMusician is the distance from the current position + a whole new musician
 e.g:     o -r- )( -r- o -r-)|
-}
nextMusician :: Int
nextMusician = radius + diameter

import Control.Monad.Random.Strict

type RandGen a = RandT StdGen IO a

-- | Helper to run the MonadRandom.
runRandGen :: RandGen a -> IO a
-- runRandGen action = evalRandT action (mkStdGen 42)
runRandGen action = do
    stdg <- initStdGen
    evalRandT action stdg

geneticSolve :: String -> Problem -> RandGen (Int, Solution)
geneticSolve name problem = do
    initialSeeds <- replicateM seedCount (randomSolution problem placements)
    ((finalScore, finalSolution) : _) <- go genCount initialSeeds
    solution <- toSolution problem finalSolution
    pure (finalScore, solution)
  where
    genCount = 3
    seedCount = 5
    breedCount = 10
    dim = (problem.problemStageWidth, problem.problemStageHeight)
    placements = toAbsPlacement problem <$> allGridPlacement dim
    total = UV.length placements
    musicianCount = UV.length problem.problemMusicians

    go :: Int -> [(Int, GenSolution)] -> RandGen [(Int, GenSolution)]
    go 0 !seeds = pure seeds
    go count !seeds = do
        -- Generate a new population
        population <- concat <$> traverse breedNewSolutions seeds

        -- Order by score
        let populationOrdered = sortOn (\(score, _) -> negate score) population
        let best = case populationOrdered of
                (score, _) : _ -> score
                _ -> minBound
        liftIO do
            now <- getCurrentTime
            sayString $ printf "%s %s: gen %2d - %10d" (take 25 $ iso8601Show now) name count best

        -- Repeat the process, keeping only the best seed.
        go (count - 1) (take seedCount populationOrdered)
      where
        breedNewSolutions :: (Int, GenSolution) -> RandGen [(Int, GenSolution)]
        breedNewSolutions x@(_, s) = do
            newSolutions <- replicateM breedCount (makeNewSeed s)
            -- Keep the original seed
            pure (x : newSolutions)

        makeNewSeed :: GenSolution -> RandGen (Int, GenSolution)
        makeNewSeed (GenSolution seedPlacements) = do
            newSolution <- GenSolution <$> MV.clone seedPlacements
            doMutate newSolution
            score <- liftIO (scoreSolution problem newSolution)
            pure (score, newSolution)

        doMutate :: GenSolution -> RandGen ()
        doMutate (GenSolution iov) = do
            mutationCount <- getRandomR (genCount, MV.length iov `div` 5)
            replicateM_ mutationCount do
                -- Pick a random musician
                musician <- getRandomR (0, musicianCount - 1)
                -- Pick a random new position
                swapPos <- getRandomR (0, total - 1)
                -- Mutate
                MV.swap iov musician swapPos

-- | All the positions are stored, that way the mutations happen in-place.
-- in 'toSolution' we keep only the one for the active musicians.
newtype GenSolution = GenSolution (MV.IOVector (Int, Int))

-- | Create a random solution.
randomSolution :: Problem -> UV.Vector (Int, Int) -> RandGen (Int, GenSolution)
randomSolution problem placements = do
    iov <- V.thaw placements
    -- Randomize the placements with the 'vector-shuffle' library
    liftRandT \stdg -> do
        newstdg <- stToIO $  VectorShuffling.Mutable.shuffle iov stdg
        pure ((), newstdg)
    let gs = GenSolution iov
    score <- liftIO (scoreSolution problem gs)
    pure (score, gs)

-- | Create the 'Solution' data from a 'GenSolution'.
toSolution :: Problem -> GenSolution -> IO Solution
toSolution problem (GenSolution iov) = do
    xs <- UV.convert <$> V.freeze iov
    pure $ Solution $ UV.take (UV.length problem.problemMusicians) xs

-- | Compute the score of a 'GenSolution'.
scoreSolution :: Problem -> GenSolution -> IO Int
scoreSolution problem gs = do
    solution <- toSolution problem gs
    pure $ scoreHappiness problem solution

newtype SubmitID = SubmitID Text
    deriving newtype (FromJSON)
    deriving (Show)

submit :: ProblemID -> Solution -> IO (Maybe SubmitID)
submit pid solution = do
    let obj = object ["problem_id" .= pid, "contents" .= decodeUtf8 (BSL.toStrict $ encode solution)]
    token <- getEnv "ICFP_TOKEN"
    manager <- newTlsManager
    initialRequest <- parseRequest "https://api.icfpcontest.com/submission"
    let request =
            initialRequest
                { method = "POST"
                , requestBody = RequestBodyLBS $ encode obj
                , requestHeaders =
                    [ ("Content-Type", "application/json")
                    , ("Authorization", "Bearer " <> encodeUtf8 (pack token))
                    ]
                }
    response <- httpLbs request manager
    if statusCode (responseStatus response) == 201
        then pure $ decode (responseBody response)
        else do
            putStrLn $ "The status code was: " ++ show (statusCode $ responseStatus response)
            print $ responseBody response
            return Nothing

newtype ProblemID = ProblemID Int
    deriving newtype (Show, Eq, Ord, Enum, Num, ToJSON)

data ProblemDescription = ProblemDescription
    { name :: ProblemID
    , problem :: Problem
    , -- a dense pillars representation using (x, y, radius)
      pillars :: UV.Vector (Int, Int, Int)
    }

data SolutionDescription = SolutionDescription
    { score :: Int
    , musicianCount :: Int
    , genPlacements :: MV.IOVector (Float, Float)
    , genVolumes :: MV.IOVector Float
    }

        -- is the musician blocked
        isBlocked = isBlockedPillar || isBlockedMusician

        -- … by a pillar (Extension 1)?
        isBlockedPillar = UV.any checkBlockedPillar problemDesc.pillars
        checkBlockedPillar :: (Int, Int, Int) -> Bool
        checkBlockedPillar (px, py, radius) = isCrossed
          where
            otherPlacement = (px, py)
            otherDistance = calcDistance attendee otherPlacement
            isCrossed = lineCrossCircle attendee placement otherDistance radius otherPlacement

        -- … by another musician?
        isBlockedMusician = UV.any checkBlocked solution.solutionPlacements

    -- Extension 2: pre-compute all the factor in advance
    calcClosenessFactor musician
        | problemDesc.name > 0 && problemDesc.name < 56 = 1 -- extension is disabled for the first problems
        | otherwise = 1 + UV.sum (UV.generate musicianCount calcMusicianDistance)
      where
        instrument = problemDesc.problem.problemMusicians UV.! musician
        musicianPos = solution.solutionPlacements UV.! musician
        calcMusicianDistance otherMusician
            | otherMusician == musician || instrument /= otherInstrument = 0
            | otherwise =
                let d = calcDistance2 musicianPos (solution.solutionPlacements UV.! otherMusician)
                 in 1 / d
          where
            otherInstrument = problemDesc.problem.problemMusicians UV.! otherMusician

-- | Packing the musicians in a grid, this function returns all the available placements.
allPackedPlacement :: (Int, Int) -> UV.Vector (Int, Int)
allPackedPlacement (width, height) = UV.fromList $ go 0 radius radius []
  where
    go
        | -- do the offset per line
          width > height = goLine
        | -- do the offset per column
          otherwise = goCol

    goLine :: Int -> Int -> Int -> [(Int, Int)] -> [(Int, Int)]
    goLine line x y !acc
        | -- there is room to fit another musician on this line
          x + nextMusician < width  = goLine line (x + diameter) y newAcc
        | -- there is room to start another line
          y + nextMusician < height = goLine (line + 1) newX (y + newOffset) newAcc
        | -- this is the end
          otherwise = newAcc
      where
        newAcc = (x, y) : acc
        -- we alternate the start position every two lines
        newX | even line = diameter
             | otherwise = radius

    goCol :: Int -> Int -> Int -> [(Int, Int)] -> [(Int, Int)]
    goCol col x y !acc
        | -- there is room to fit another musician on this column
          y + nextMusician < height = goCol col x (y + diameter) newAcc
        | -- there is room to start another column
          x + nextMusician < width  = goCol (col + 1) (x + newOffset) newY newAcc
        | -- this is the end
          otherwise = newAcc
      where
        newAcc = (x, y) : acc
        -- we alternate the start position every two columns
        newY | even col = diameter
             | otherwise = radius

    -- best offset using int
    newOffset = 19

maximumPlacements :: Problem -> UV.Vector (Int, Int)
maximumPlacements problem = UV.map toAbsPlacement best
  where
    best | UV.length packed > UV.length grid = packed
         | otherwise = grid
    packed = allPackedPlacement dim
    grid = allGridPlacement dim
    dim = (problem.problemStageWidth, problem.problemStageHeight)

    toAbsPlacement :: (Int, Int) -> (Int, Int)
    toAbsPlacement (x, y) = (sx + x, sy + y)
      where
        (sx, sy) = problem.problemStageBottomLeft

mainDriver :: Int -> IO ()
mainDriver maxTime = do
  let dryRun = False
  putStrLn $ printf "Starting driver with max %d seconds"  maxTime

  -- start from the smallest score
  solutions <- _sortProblemByScore

  -- start from the oldest solution
  -- solutions <- _sortProblemByDate

  now <- getCurrentTime
  let solutionsOrdered =
        -- Focus on the first few problems
        take 12 $
        -- Start from the biggest/recent one
        reverse solutions
        -- Start from the smallest/oldest
        -- solution

  forM_ solutionsOrdered \(pid, time) -> do
    let
      ageSec :: Integer
      ageSec = truncate (nominalDiffTimeToSeconds $ diffUTCTime now time) `div` 60
    solution <- loadSolutionPath (solutionPath pid)
    putStrLn $ printf "Trying to improve problem-%02s (%4s minutes old): %13s"
      (show pid)
      (show ageSec)
      (showScore solution.score)
    problem <- loadProblem pid
    start_time <- getCurrentTime
    unless dryRun do
      improved <- runRandGen $ mainImprove maxTime problem start_time start_time solution 0
      when improved do
        void $ forkIO $ submitOne pid

-- | This function call 'tryImprove' repeatedly. It returns True on success.
mainImprove :: Int -> ProblemDescription -> UTCTime -> UTCTime -> SolutionDescription -> Int -> RandGen Bool
mainImprove maxTime problemDesc initial_time start_time solutionDesc idx = do
  -- maybe get a new solution
  mSolution <- tryImprove problemDesc solutionDesc (toEnum (idx `mod` 3))

  (newTime, newSolution) <- case mSolution of
    Nothing -> pure (start_time, solutionDesc) -- no improvement
    Just sd -> liftIO do
      saveSolutionPath sd (solutionPath problemDesc.name)
      now <- getCurrentTime
      sayString $ printf "%s #%02s new highscore:%14s (+%10s)"
          (formatLogTime now)
          (show problemDesc.name)
          (showScore solutionDesc.score)
          (showScore $ sd.score - solutionDesc.score)
      pure (now, sd)

  -- check how long we ran sinch the last improvement
  end_time <- liftIO getCurrentTime
  let elapsed = nominalDiffTimeToSeconds (diffUTCTime end_time start_time)
      hasImproved = initial_time /= start_time -- start_time is increased by improvements
  if elapsed < fromIntegral maxTime
    then mainImprove maxTime problemDesc initial_time newTime newSolution (idx + 1)
    else pure hasImproved

data Mutation = Placement | Volume | Both
    deriving (Enum, Bounded, Show)

-- | This function simply try to improve a given solution by applying a single mutation
tryImprove :: ProblemDescription -> SolutionDescription -> Mutation -> RandGen (Maybe SolutionDescription)
tryImprove problemDesc sd mutation = do
    newSolution <- case mutation of
        Placement -> do
            genPlacements <- newPlacements
            pure $ sd{genPlacements}
        Volume -> do
            genVolumes <- newVolumes
            pure $ sd{genVolumes}
        Both -> do
            genPlacements <- newPlacements
            genVolumes <- newVolumes
            pure $ sd{genPlacements, genVolumes}

    score <- scoreSolution problemDesc newSolution.genPlacements newSolution.genVolumes
    pure $
        if score > sd.score
            then Just (newSolution{score})
            else Nothing
  where
    musicianCount = UV.length problemDesc.problem.problemMusicians
    newPlacements = do
        -- Copy the previous placements and do one swap
        iov <- MV.clone sd.genPlacements.iov
        musician <- getRandomR (0, musicianCount - 1)
        swapPos <- getRandomR (0, MV.length iov - 1)
        MV.swap iov musician swapPos
        pure $ GenPlacements iov
    newVolumes = do
        -- Copy the previous volumes and do one change
        iov <- MV.clone sd.genVolumes
        musician <- getRandomR (0, musicianCount - 1)
        volume <- getRandomR (0, 10)
        -- TODO: to a relative increase of the current volume?
        MV.write iov musician volume
        pure iov

  mainDriver :: Int -> IO ()
- mainDriver maxTime = do
+ mainDriver maxTime = withScheduler_ Par \scheduler -> do
    let dryRun = False

-   forM_ solutions \(pid, time) -> do
+   forM_ solutions \(pid, time) -> scheduleWork_ scheduler do
      let ageSec :: Integer