96 lines
2.5 KiB
Fortran
96 lines
2.5 KiB
Fortran
program apartment_puzzle
|
|
implicit none
|
|
integer :: domains(5,5) ! domains(person, floor) = 1 if possible
|
|
integer :: solution(5)
|
|
logical :: found
|
|
|
|
! Initialize: all assignments possible, solution unassigned
|
|
domains = 1
|
|
solution = 0
|
|
|
|
! Apply unary constraints
|
|
domains(1, 5) = 0 ! Baker not on top
|
|
domains(2, 1) = 0 ! Cooper not on bottom
|
|
domains(3, 1) = 0 ! Fletcher not on bottom
|
|
domains(3, 5) = 0 ! Fletcher not on top
|
|
|
|
call solve_csp(domains, solution, 1, found)
|
|
|
|
if (found) then
|
|
print *, "Baker: ", solution(1)
|
|
print *, "Cooper: ", solution(2)
|
|
print *, "Fletcher:", solution(3)
|
|
print *, "Miller: ", solution(4)
|
|
print *, "Smith: ", solution(5)
|
|
else
|
|
print *, "No solution found"
|
|
end if
|
|
|
|
contains
|
|
|
|
recursive subroutine solve_csp(dom, sol, person, found)
|
|
integer, intent(in) :: dom(5,5)
|
|
integer, intent(inout) :: sol(5)
|
|
integer, intent(in) :: person
|
|
logical, intent(out) :: found
|
|
integer :: floor, new_dom(5,5)
|
|
|
|
if (person > 5) then
|
|
found = check_all_constraints(sol)
|
|
return
|
|
end if
|
|
|
|
found = .false.
|
|
do floor = 1, 5
|
|
if (dom(person, floor) == 0) cycle
|
|
if (any(sol(1:person-1) == floor)) cycle ! Floor already taken
|
|
|
|
sol(person) = floor
|
|
|
|
! Check constraints so far
|
|
if (.not. check_partial_constraints(sol, person)) then
|
|
sol(person) = 0
|
|
cycle
|
|
end if
|
|
|
|
! Forward check: propagate constraints
|
|
new_dom = dom
|
|
new_dom(:, floor) = 0 ! Remove this floor from remaining
|
|
|
|
call solve_csp(new_dom, sol, person + 1, found)
|
|
if (found) return
|
|
|
|
sol(person) = 0
|
|
end do
|
|
end subroutine
|
|
|
|
function check_partial_constraints(sol, up_to) result(valid)
|
|
integer, intent(in) :: sol(5), up_to
|
|
logical :: valid
|
|
|
|
valid = .true.
|
|
|
|
! Miller > Cooper (if both assigned)
|
|
if (up_to >= 4 .and. sol(4) > 0 .and. sol(2) > 0) then
|
|
if (sol(4) <= sol(2)) valid = .false.
|
|
end if
|
|
|
|
! Smith not adjacent Fletcher (if both assigned)
|
|
if (up_to >= 5 .and. sol(5) > 0 .and. sol(3) > 0) then
|
|
if (abs(sol(5) - sol(3)) == 1) valid = .false.
|
|
end if
|
|
|
|
! Fletcher not adjacent Cooper (if both assigned)
|
|
if (up_to >= 3 .and. sol(3) > 0 .and. sol(2) > 0) then
|
|
if (abs(sol(3) - sol(2)) == 1) valid = .false.
|
|
end if
|
|
end function
|
|
|
|
function check_all_constraints(sol) result(valid)
|
|
integer, intent(in) :: sol(5)
|
|
logical :: valid
|
|
|
|
valid = check_partial_constraints(sol, 5)
|
|
end function
|
|
|
|
end program
|