Advent of Code 2021 Solutions in OCaml

day01.ml

let read_lines () =
  let rec aux lines =
    try
      let line = input_line stdin in
      aux @@ line :: lines
    with End_of_file ->
      lines
  in
  List.rev @@ aux []

let read_measurements () =
  List.map int_of_string @@ read_lines ()

let count_measurement_increases measurements =
  let rec aux m a =
    match m with
    | x1 :: x2 :: rest ->
       let a = if x2 > x1 then a + 1 else a in
       aux (x2 :: rest) a
    | _ :: [] | [] -> a
  in
  aux measurements 0

let () =
  read_measurements ()
  |> count_measurement_increases
  |> Printf.printf "%d\n"

day02.ml

module Move = struct
  type t = Forward of int | Down of int | Up of int

  let of_string line =
    let move_of_string move size =
      match move with
      | "forward" -> Forward size
      | "down" -> Down size
      | "up" -> Up size
      | invalid -> failwith ("Invalid move " ^ invalid)
    in
    match String.split_on_char ' ' line with
    | move :: size :: [] ->
       let size = int_of_string size in
       move_of_string move size
    | _ -> failwith "Wrong line format, should be 'movement size', eg 'up 2'"
end

module Position = struct
  type t = { horizontal: int
           ; depth: int }

  let empty = { horizontal = 0
              ; depth = 0 }

  let move t movement =
    let open Move in
    match movement with
    | Forward x -> { t with
                     horizontal = t.horizontal + x }
    | Down x    -> { t with
                     depth = t.depth + x}
    | Up x      -> { t with
                     depth = t.depth - x}

  let to_scalar t =
    t.horizontal * t.depth
end

let readlines () =
  let rec aux lines =
    try
      let line = read_line () in
      aux @@ line :: lines
    with End_of_file ->
      lines
  in
  List.rev @@ aux []

let () =
  readlines ()
  |> List.map Move.of_string
  |> List.fold_left Position.move Position.empty
  |> Position.to_scalar
  |> Printf.printf "%d"

day03.ml

module IntMap = struct
  include Map.Make(Int)

  let find_default ~default key t =
    Option.value ~default @@ find_opt key t

  let add_swap ~default f key t =
    add key (f @@ find_default ~default key t) t
end

let read_lines =
  Seq.unfold (fun _ -> try Some (read_line (), ()) with End_of_file -> None)

let count_line map line =
  line
  |> String.to_seqi
  |> Seq.fold_left
       (fun map (i, c) ->
         IntMap.add_swap ~default:0
           ((+) (if c = '1' then 1 else 0))
           i map)
       map

let () =
  let lines = read_lines () in
  let (map, count) =
    Seq.fold_left
      (fun (map, count) line -> (count_line map line, count + 1))
      (IntMap.empty, 0)
      lines
  in
  let gamma =
    IntMap.fold
      (fun key value acc ->
        (* This is a naive assumption that there is at least one
           bit 1 for all indexes *)
        (acc lsl 1) lor (if value > (count / 2) then 1 else 0))
      map 0;
  in
  let epsilon =
    (* Other naive assumption about layout, here it assumes that the
       MSB has at least 1 *)
    let (size, _) = IntMap.max_binding map in
    let mask = lnot 0 lxor (lnot 0 lsl size) in
    lnot gamma land mask
  in
  Printf.printf "%d\n" (gamma * epsilon)

day04.ml

#load "str.cma"

let range n =
  let rec aux lst i =
    if i = n then
      lst
    else
      i :: aux lst (i + 1)
  in
  aux [] 0

module Numbers = struct
  include Set.Make(Int)

  let has_been_drawn t number =
    mem number t
end

module Board = struct
  type t = int array array

  let make lst =
    lst
    |> List.map Array.of_list
    |> Array.of_list

  let has_won numbers board =
    let on_row =
      Array.exists
        (Array.for_all
           (Numbers.has_been_drawn numbers))
        board
    in
    let on_column =
      List.exists
        (fun i ->
          board
          |> Array.map (fun row -> row.(i))
          |> Array.for_all (Numbers.has_been_drawn numbers))
        (range 5)
    in
    on_row || on_column

  let find_winning_board boards numbers =
    List.find_opt (has_won numbers) boards
end

module Bingo = struct
  type t = { last_number: int
           ; drawn: Numbers.t 
           ; winning_board: Board.t }

  let find_winning_board boards numbers =
    let rec aux boards drawn queue =
      let (last_number, drawn, queue) =
        match queue with
        | x :: rest -> x, Numbers.add x drawn, rest
        | [] -> assert false
      in
      match Board.find_winning_board boards drawn with
      | Some board -> { last_number
                      ; drawn
                      ; winning_board = board }
      | None -> aux boards drawn queue
    in
    aux boards Numbers.empty numbers

  let score t =
    t.winning_board
    |> Array.map Array.to_list
    |> Array.to_list
    |> List.flatten
    |> List.filter (fun n -> not (Numbers.has_been_drawn t.drawn n))
    |> List.fold_left (+) 0
    |> ( * ) t.last_number
end

let read_numbers () =
  let line = read_line () in
  line
  |> String.split_on_char ','
  |> List.map int_of_string

let spaces = Str.regexp "[ ]+"

let read_board () =
  assert (read_line () = "");

  List.map
    (fun _ ->
      read_line ()
      |> Str.split spaces
      |> List.map int_of_string)
    (range 5)

let read_boards () =
  let rec aux boards =
    try
      aux (read_board () :: boards)
    with End_of_file ->
      boards
  in
  List.map Board.make @@ List.rev @@ aux []

let () =
  let numbers = read_numbers () in
  let boards = read_boards () in
  let bingo = Bingo.find_winning_board boards numbers in
  Printf.printf "%d\n" (Bingo.score bingo)

day05.ml

#load "str.cma"

module Coordinate = struct
  type t = int * int

  let make x y =
    x, y

  let compare (x1, y1) (x2, y2) =
    match x1 - x2 with
    | 0 -> y1 - y2
    | c -> c
end

module Line = struct
  type t = Coordinate.t * Coordinate.t

  let make x1 y1 x2 y2 =
    (Coordinate.make x1 y1), (Coordinate.make x2 y2)
end

module Diagram = struct
  include Map.Make(Coordinate)

  type direction = X | Y

  let swap ~default t key f =
    match find_opt key t with
    | Some value -> add key (f value) t
    | None -> add key (f default) t

  let add t ((x1, y1), (x2, y2)) =
    let rec add_points t fixed src dst direction =
      let coordinate =
        match direction with
        | X -> Coordinate.make src fixed
        | Y -> Coordinate.make fixed src
      in
      let t = swap ~default:0 t coordinate ((+) 1) in
      if src = dst then t
      else add_points t fixed (src + 1) dst direction
    in
    match (x1 = x2, y1 = y2) with
    | (true, _) ->
       let (src, dst) = if y1 > y2 then (y2, y1) else (y1, y2) in
       add_points t x1 src dst Y
    | (_, true) ->
       let (src, dst) = if x1 > x2 then (x2, x1) else (x1, x2) in
       add_points t y1 src dst X
    | _ -> t

  let filter f t =
    filter (fun _ value -> f value) t
end

module IO = struct
  let coord_sep = Str.regexp " -> "

  let read_coordinate () =
    let line =
      read_line ()
      |> Str.split coord_sep
      |> List.map (String.split_on_char ',')
      |> List.map (List.map int_of_string)
    in
    match line with
    | p1 :: p2 :: [] ->
       begin
         match p1, p2 with
         | x1 :: y1 :: [], x2 :: y2 :: [] ->
            Line.make x1 y1 x2 y2
         | _ -> assert false
       end
    | _ -> assert false

  let read_lines () =
    Seq.unfold
      (fun _ ->
        try
          Some (read_coordinate (), ())
        with End_of_file ->
          None)
      ()
end

let () =
  IO.read_lines ()
  |> Seq.fold_left Diagram.add Diagram.empty
  |> Diagram.filter ((<) 1)
  |> Diagram.cardinal
  |> Printf.printf "%d\n"

day06.ml

let range n =
  let rec aux lst i =
    if i = n then lst else i :: aux lst (i + 1)
  in
  aux [] 0

module Fish = struct
  type t = int

  let of_string = int_of_string

  let to_string = string_of_int

  let step = function
    | 0 -> 6
    | x -> x - 1
end

module Schoal = struct
  type t = Fish.t List.t

  let rec step old_fish new_fish =
    match old_fish with
    | x :: xs ->
       let new_fish =
         match x with
         | 0 -> 8 :: new_fish
         | _ -> new_fish
       in
       step xs @@ Fish.step x :: new_fish
    | [] -> new_fish

  let step t =
    step t []

  let count = List.length

  let to_string t =
    String.concat "," @@ List.map Fish.to_string t
end

let read_fish () =
  read_line ()
  |> String.split_on_char ','
  |> List.map Fish.of_string

let () =
  let schoal =
    List.fold_left
      (fun schoal _ -> Schoal.step schoal)
      (read_fish ())
      (range 80)
  in
  schoal
  |> Schoal.count
  |> Printf.printf "%d\n"

day07.ml

let range n =
  Array.mapi (fun i _ -> i) @@ Array.make n 0

module Swarm = struct
  type t = int array array

  let make crabs =
    let len = Array.length crabs in
    let max = Array.fold_left Int.max 0 crabs in

    let matrix = Array.make_matrix max len 0 in
    let positions = range (max + 1) in

    for i = 0 to max - 1 do
      for j = 0 to len - 1 do
        matrix.(i).(j) <- Int.abs (crabs.(j) - positions.(i))
      done
    done;

    matrix

  let min_consumption swarm =
    swarm
    |> Array.map (Array.fold_left (+) 0)
    |> Array.fold_left Int.min Int.max_int
end

let read_crabs () =
  read_line ()
  |> String.split_on_char ','
  |> List.map int_of_string
  |> Array.of_list

let () =
  read_crabs ()
  |> Swarm.make
  |> Swarm.min_consumption
  |> Printf.printf "%d\n"