partridge/bin/main.ml

(*let debugf = Format.ifprintf Format.std_formatter*)

let pp_card out ((x, y), n) = Format.fprintf out "((%d, %d), %d)" x y n

let intersects ((x1l, y1b), n1) ((x2l, y2b), n2) =
  let x1r = x1l + n1 in
  let x2r = x2l + n2 in
  let y1t = y1b + n1 in
  let y2t = y2b + n2 in
  let result = x1l < x2r && x1r > x2l && y1t > y2b && y1b < y2t in
  begin
    result
  end

let rec card_fits size idx placed_cards (x, y) =
  if x + idx > size then false
  else if y + idx > size then false
  else
    match placed_cards with
    | [] -> true
    | h :: t ->
        if intersects h ((x, y), idx) then false else card_fits size idx t (x, y)

let rec in_card (x, y) cards =
  match cards with
  | [] -> false
  | ((a, b), n) :: t ->
      if x >= a && x < a + n && y >= b && y < b + n then true
      else in_card (x, y) t

let next_pos size (x, y) cards =
  let rec impl x y =
    if x >= size then impl 0 (y + 1)
    else if in_card (x, y) cards then impl (x + 1) y
    else (x, y)
  in
  impl (x + 1) y

(*let pp_pos out (x, y) = Format.fprintf out "(@[%d,@ %d@])" x y*)

let rec find_solutions_impl cards size n idx current_alloc current_pos =
  begin
    (*debugf "find_solutions_impl:@ @[<hov>%a@ %d@ %d@ %d@ %a@ %a@]@;@?"
	(Format.pp_print_array Format.pp_print_int) cards
	size n idx
	(Format.pp_print_list pp_card) current_alloc
	pp_pos current_pos;*)
    if current_pos = (0, size) then current_alloc
    else if idx = 0 then []
    else if cards.(idx) = 0 then
      find_solutions_impl cards size n (idx - 1) current_alloc current_pos
    else if card_fits size idx current_alloc current_pos then begin
      Array.set cards idx (cards.(idx) - 1);
      let new_alloc = (current_pos, idx) :: current_alloc in
      let new_pos = next_pos size current_pos new_alloc in
      let alloc = find_solutions_impl cards size n n new_alloc new_pos in
      Array.set cards idx (cards.(idx) + 1);
      if List.is_empty alloc then
        find_solutions_impl cards size n (idx - 1) current_alloc current_pos
      else alloc
    end
    else find_solutions_impl cards size n (idx - 1) current_alloc current_pos
  end

let find_solutions cards size =
  find_solutions_impl cards size
    (Array.length cards - 1)
    (Array.length cards - 1)
    [] (0, 0)

exception Overlapping_value

let print_solution size cards =
  let array = Array.make (size * size) '.' in
  let set_pos x y c =
    if array.(x + (y * size)) <> '.' then raise Overlapping_value
    else Array.set array (x + (y * size)) c
  in
  let rec write_size x y n =
    if n = 0 then ()
    else begin
      Array.set array (x + (y * size)) (Char.chr (48 + (n mod 10)));
      write_size (x - 1) y (n / 10)
    end
  in
  let rec impl cards =
    match cards with
    | [] -> ()
    | ((x, y), n) :: t -> begin
        if n = 1 then set_pos x y '*'
        else if n = 2 then begin
          set_pos x y '+';
          set_pos (x + 1) y '+';
          set_pos x (y + 1) '+';
          set_pos (x + 1) (y + 1) '+'
        end
        else begin
          set_pos x y '+';
          set_pos (x + n - 1) y '+';
          set_pos x (y + n - 1) '+';
          set_pos (x + n - 1) (y + n - 1) '+';
          for a = 1 to n - 2 do
            set_pos (x + a) y '-';
            set_pos (x + a) (y + n - 1) '-';
            for b = 1 to n - 2 do
              set_pos (x + a) (y + b) ' '
            done;
            set_pos x (y + a) '|';
            set_pos (x + n - 1) (y + a) '|'
          done;
          write_size (x + n - 2) (y + 1) n
        end;
        impl t
      end
  in
  impl cards;
  for y = 0 to size - 1 do
    for x = 0 to size - 1 do
      Format.printf "%c" array.(x + (y * size))
    done;
    Format.printf "\n"
  done

let n = 8
let tri_n = (n + 1) * n / 2

(* Cards is an array initialised so that cards[x] = x for x = [0..9].

   These are the cards we need to fit into the square of length tri_n.
 *)
let cards = Array.init (n + 1) Fun.id
let soln = find_solutions cards tri_n
let () = Format.printf "@[<hov>Base number: %d,@;side length: %d@;" n tri_n
let () = Format.printf "Solution: %a@]@\n" (Format.pp_print_list pp_card) soln
let () = print_solution tri_n soln