program word_search_rosetta_complete
    implicit none

    integer, parameter :: GRID_SIZE = 10
    integer, parameter :: MAX_WORDS = 5000
    integer, parameter :: MAX_WORD_LEN = 20
    integer, parameter :: MIN_PLACED = 25

    character(len=1) :: grid(GRID_SIZE, GRID_SIZE)
    character(len=MAX_WORD_LEN) :: words(MAX_WORDS), original_words(MAX_WORDS)
    integer :: word_lens(MAX_WORDS), original_lens(MAX_WORDS)
    integer :: num_words
    integer :: length_limits(3:10)

    type :: word_placement
        character(len=MAX_WORD_LEN) :: word
        integer :: row, col
        integer :: dx, dy
    end type

    type(word_placement) :: placed(200), all_found(500)
    integer :: num_placed, num_found

    integer :: attempt

    call init_random_seed()
    call load_words(original_words, original_lens, num_words)
    print '(A,I0,A)', "Loaded ", num_words, " valid words"

    ! Try to create puzzle
    do attempt = 1, 10
        words = original_words
        word_lens = original_lens

        call create_puzzle(words, word_lens, num_words, grid, placed, num_placed)

        ! VB stops when we have 25+ words (success!)
        if (num_placed >= MIN_PLACED) then
            print '(A,I0)', "Success on attempt ", attempt

            ! Find ALL words embedded in the final grid
            call find_all_words(original_words, original_lens, num_words, grid, all_found, num_found)

            call print_results(grid, placed, num_placed, all_found, num_found)
            exit
        end if

        print '(A,I0,A,I0,A)', "Attempt ", attempt, " placed ", num_placed, " words, retrying..."
    end do

contains

    subroutine init_random_seed()
        integer :: seed_size, clock, i
        integer, allocatable :: seed(:)

        call random_seed(size=seed_size)
        allocate(seed(seed_size))
        call system_clock(count=clock)
        seed = clock + 37 * [(i, i=1, seed_size)]
        call random_seed(put=seed)
        deallocate(seed)
    end subroutine

    subroutine load_words(words, word_lens, num_words)
        character(len=*), intent(out) :: words(:)
        integer, intent(out) :: word_lens(:)
        integer, intent(out) :: num_words
        character(len=MAX_WORD_LEN) :: word
        integer :: ios, i
        logical :: valid

        num_words = 0

        open(10, file='unixdict.txt', status='old', action='read', iostat=ios)
        if (ios /= 0) then
            print *, "Error opening unixdict.txt"
            stop
        end if

        do
            read(10, '(A)', iostat=ios) word
            if (ios /= 0) exit

            word = trim(word)
            if (len_trim(word) <= 2 .or. len_trim(word) > 10) cycle

            valid = .true.
            do i = 1, len_trim(word)
                if (word(i:i) < 'a' .or. word(i:i) > 'z') then
                    valid = .false.
                    exit
                end if
            end do

            if (valid) then
                num_words = num_words + 1
                if (num_words > MAX_WORDS) exit
                words(num_words) = trim(word)
                word_lens(num_words) = len_trim(word)
            end if
        end do

        close(10)
    end subroutine

    subroutine shuffle_words(words, word_lens, num_words)
        character(len=*), intent(inout) :: words(:)
        integer, intent(inout) :: word_lens(:)
        integer, intent(in) :: num_words
        integer :: i, r, temp_len
        character(len=MAX_WORD_LEN) :: temp_word
        real :: rr

        do i = num_words, 2, -1
            call random_number(rr)
            r = int(rr * i) + 1

            temp_word = words(i)
            words(i) = words(r)
            words(r) = temp_word

            temp_len = word_lens(i)
            word_lens(i) = word_lens(r)
            word_lens(r) = temp_len
        end do
    end subroutine

    function count_spaces(grid) result(count)
        character(len=1), intent(in) :: grid(:,:)
        integer :: count, i, j

        count = 0
        do i = 1, GRID_SIZE
            do j = 1, GRID_SIZE
                if (grid(j, i) == ' ') count = count + 1
            end do
        end do
    end function

    subroutine create_puzzle(words, word_lens, num_words, grid, placed, num_placed)
        character(len=*), intent(inout) :: words(:)
        integer, intent(inout) :: word_lens(:)
        integer, intent(in) :: num_words
        character(len=1), intent(out) :: grid(:,:)
        type(word_placement), intent(out) :: placed(:)
        integer, intent(out) :: num_placed

        integer :: i
        real :: r

        ! Initialize grid
        grid = ' '
        num_placed = 0

        ! Pre-seed ROSETTACODE letters (VB strategy)
        call random_number(r)
        grid(int(r * 5) + 6, 1) = 'R'

        call random_number(r)
        grid(int(r * 9) + 2, 2) = 'O'

        call random_number(r)
        grid(int(r * 9) + 2, 3) = 'S'

        call random_number(r)
        grid(int(r * 9) + 2, 4) = 'E'

        grid(2, 5) = 'T'
        grid(10, 5) = 'T'

        call random_number(r)
        grid(int(r * 10) + 1, 6) = 'A'

        call random_number(r)
        grid(int(r * 10) + 1, 7) = 'C'

        call random_number(r)
        grid(int(r * 10) + 1, 8) = 'O'

        call random_number(r)
        grid(int(r * 10) + 1, 9) = 'D'

        call random_number(r)
        grid(int(r * 10) + 1, 10) = 'E'

        ! Set length limits (pack the grid EXTREMELY full like VB)
        length_limits(3) = 500   ! VB had 200 - go even higher
        length_limits(4) = 100
        length_limits(5) = 50
        length_limits(6) = 30
        length_limits(7) = 20
        length_limits(8) = 10
        length_limits(9) = 5
        length_limits(10) = 3

        ! Shuffle words
        call shuffle_words(words, word_lens, num_words)

        ! Place words systematically (VB strategy - FILL THE GRID!)
        do i = 1, num_words
            ! VB stops when grid is completely full
            if (count_spaces(grid) == 0) exit

            ! Check length limit
            if (word_lens(i) >= 3 .and. word_lens(i) <= 10) then
                if (length_limits(word_lens(i)) > 0) then
                    if (place_word_systematic(words(i), word_lens(i), grid, placed, num_placed)) then
                        length_limits(word_lens(i)) = length_limits(word_lens(i)) - 1
                    end if
                end if
            end if
        end do

        ! Fill remaining spaces with random lowercase
        call fill_remaining(grid)
    end subroutine

    logical function place_word_systematic(word, word_len, grid, placed, num_placed)
        character(len=*), intent(in) :: word
        integer, intent(in) :: word_len
        character(len=1), intent(inout) :: grid(:,:)
        type(word_placement), intent(inout) :: placed(:)
        integer, intent(inout) :: num_placed

        integer :: start_pos, test_num, spot, x, y, d, dir_test
        integer :: dx(0:7), dy(0:7)
        integer :: rdir, rdd
        real :: r

        ! Direction arrays
        dx = [1, 1, 0, -1, -1, -1, 0, 1]
        dy = [0, 1, 1, 1, 0, -1, -1, -1]

        place_word_systematic = .false.

        ! Random starting position
        call random_number(r)
        start_pos = int(r * 100)

        ! Random direction to traverse grid
        call random_number(r)
        if (r < 0.5) then
            rdir = -1
        else
            rdir = 1
        end if

        ! Try all 100 positions
        do test_num = 0, 99
            spot = mod(start_pos + test_num * rdir + 100, 100)
            y = spot / 10 + 1
            x = mod(spot, 10) + 1

            ! If first letter matches or space is empty
            if (grid(x, y) == word(1:1) .or. grid(x, y) == ' ' .or. &
                (grid(x, y) >= 'A' .and. grid(x, y) <= 'Z' .and. &
                 char(ichar(grid(x, y)) + 32) == word(1:1))) then

                ! Try all 8 directions
                call random_number(r)
                d = int(r * 8)
                call random_number(r)
                if (r < 0.5) then
                    rdd = -1
                else
                    rdd = 1
                end if

                do dir_test = 0, 7
                    d = mod(d + dir_test * rdd + 8, 8)

                    if (can_place_vb(word, word_len, x, y, dx(d), dy(d), grid)) then
                        call place_word_vb(word, word_len, x, y, dx(d), dy(d), grid)
                        num_placed = num_placed + 1
                        placed(num_placed)%word = trim(word)
                        placed(num_placed)%col = x
                        placed(num_placed)%row = y
                        placed(num_placed)%dx = dx(d)
                        placed(num_placed)%dy = dy(d)
                        place_word_systematic = .true.
                        return
                    end if
                end do
            end if
        end do
    end function

    logical function can_place_vb(word, word_len, x, y, dx, dy, grid)
        character(len=*), intent(in) :: word
        integer, intent(in) :: word_len, x, y, dx, dy
        character(len=1), intent(in) :: grid(:,:)

        integer :: i, cx, cy
        logical :: fills_something
        character(len=1) :: grid_char

        can_place_vb = .false.
        fills_something = .false.

        ! Check bounds
        do i = 0, word_len - 1
            cx = x + i * dx
            cy = y + i * dy
            if (cx < 1 .or. cx > GRID_SIZE .or. cy < 1 .or. cy > GRID_SIZE) return
        end do

        ! Check if can place and if fills at least one space
        do i = 0, word_len - 1
            cx = x + i * dx
            cy = y + i * dy
            grid_char = grid(cx, cy)

            if (grid_char == ' ') then
                fills_something = .true.
            else if (grid_char /= word(i+1:i+1)) then
                ! Allow uppercase match
                if (grid_char >= 'A' .and. grid_char <= 'Z') then
                    if (char(ichar(grid_char) + 32) /= word(i+1:i+1)) return
                else
                    return
                end if
            end if
        end do

        can_place_vb = fills_something
    end function

    subroutine place_word_vb(word, word_len, x, y, dx, dy, grid)
        character(len=*), intent(in) :: word
        integer, intent(in) :: word_len, x, y, dx, dy
        character(len=1), intent(inout) :: grid(:,:)

        integer :: i, cx, cy

        do i = 0, word_len - 1
            cx = x + i * dx
            cy = y + i * dy
            ! Only place lowercase if empty or already matches
            if (grid(cx, cy) == ' ' .or. grid(cx, cy) == word(i+1:i+1)) then
                grid(cx, cy) = word(i+1:i+1)
            end if
        end do
    end subroutine

    subroutine fill_remaining(grid)
        character(len=1), intent(inout) :: grid(:,:)
        integer :: i, j
        real :: r

        do i = 1, GRID_SIZE
            do j = 1, GRID_SIZE
                if (grid(j, i) == ' ') then
                    call random_number(r)
                    grid(j, i) = char(int(r * 26) + ichar('a'))
                end if
            end do
        end do
    end subroutine

    subroutine find_all_words(words, word_lens, num_words, grid, all_found, num_found)
        character(len=*), intent(in) :: words(:)
        integer, intent(in) :: word_lens(:)
        integer, intent(in) :: num_words
        character(len=1), intent(in) :: grid(:,:)
        type(word_placement), intent(out) :: all_found(:)
        integer, intent(out) :: num_found

        integer :: i, x, y, d, j, cx, cy
        integer :: dx(0:7), dy(0:7)
        character(len=MAX_WORD_LEN) :: template
        logical :: matches

        dx = [1, 1, 0, -1, -1, -1, 0, 1]
        dy = [0, 1, 1, 1, 0, -1, -1, -1]

        num_found = 0

        do i = 1, num_words
            do y = 1, GRID_SIZE
                do x = 1, GRID_SIZE
                    ! Check if first letter matches (case-insensitive)
                    if (grid(x, y) /= words(i)(1:1) .and. &
                        char(ichar(grid(x, y)) - 32) /= char(ichar(words(i)(1:1)) - 32)) cycle

                    do d = 0, 7
                        ! Check bounds
                        cx = x + (word_lens(i) - 1) * dx(d)
                        cy = y + (word_lens(i) - 1) * dy(d)
                        if (cx < 1 .or. cx > GRID_SIZE .or. cy < 1 .or. cy > GRID_SIZE) cycle

                        ! Build template
                        template = ''
                        do j = 0, word_lens(i) - 1
                            cx = x + j * dx(d)
                            cy = y + j * dy(d)
                            template(j+1:j+1) = grid(cx, cy)
                        end do

                        ! Check match (case-insensitive)
                        matches = .true.
                        do j = 1, word_lens(i)
                            if (template(j:j) /= words(i)(j:j) .and. &
                                char(ichar(template(j:j)) - 32) /= char(ichar(words(i)(j:j)) - 32)) then
                                matches = .false.
                                exit
                            end if
                        end do

                        if (matches) then
                            num_found = num_found + 1
                            if (num_found > 500) return
                            all_found(num_found)%word = trim(words(i))
                            all_found(num_found)%col = x
                            all_found(num_found)%row = y
                            all_found(num_found)%dx = dx(d)
                            all_found(num_found)%dy = dy(d)
                        end if
                    end do
                end do
            end do
        end do
    end subroutine

    subroutine print_results(grid, placed, num_placed, all_found, num_found)
        character(len=1), intent(in) :: grid(:,:)
        type(word_placement), intent(in) :: placed(:), all_found(:)
        integer, intent(in) :: num_placed, num_found

        integer :: i, j, uppercase_count
        character(len=20) :: dir_name

        print *
        print *, "Word Search Puzzle (10x10)"
        print *, "=========================="
        print *

        write(*, '(A)', advance='no') "    "
        do j = 0, 9
            write(*, '(I2)', advance='no') j
        end do
        print *
        print *

        do i = 1, GRID_SIZE
            write(*, '(I3,A)', advance='no') i-1, "  "
            do j = 1, GRID_SIZE
                write(*, '(A2)', advance='no') grid(j, i)
            end do
            print *
        end do

        uppercase_count = 0
        do i = 1, GRID_SIZE
            do j = 1, GRID_SIZE
                if (grid(j, i) >= 'A' .and. grid(j, i) <= 'Z') uppercase_count = uppercase_count + 1
            end do
        end do

        print *
        print '(A,I0)', "ROSETTACODE letters: ", uppercase_count
        print *
        print '(A,I0,A)', "Words placed: ", num_placed
        print '(A,I0,A)', "Total words found embedded: ", num_found, " (including overlaps)"
        print *, "=========================="
        print *

        print *, "Placed words:"
        do i = 1, min(num_placed, 50)
            dir_name = get_direction_name(placed(i)%dx, placed(i)%dy)
            write(*, '(I3,A,A12,A,I2,A,I2,A,A)') &
                i, '. ', trim(placed(i)%word), &
                ' (', placed(i)%col-1, ',', placed(i)%row-1, ') ', trim(dir_name)
        end do

        print *
        print *, "All words found in grid:"
        do i = 1, min(num_found, 100)
            dir_name = get_direction_name(all_found(i)%dx, all_found(i)%dy)
            write(*, '(I3,A,A12,A,I2,A,I2,A,A)') &
                i, '. ', trim(all_found(i)%word), &
                ' (', all_found(i)%col-1, ',', all_found(i)%row-1, ') ', trim(dir_name)
        end do
    end subroutine

    function get_direction_name(dx, dy) result(name)
        integer, intent(in) :: dx, dy
        character(len=20) :: name

        if (dy == 0 .and. dx > 0) then
            name = "E"
        else if (dy == 0 .and. dx < 0) then
            name = "W"
        else if (dx == 0 .and. dy > 0) then
            name = "S"
        else if (dx == 0 .and. dy < 0) then
            name = "N"
        else if (dx > 0 .and. dy > 0) then
            name = "SE"
        else if (dx > 0 .and. dy < 0) then
            name = "NE"
        else if (dx < 0 .and. dy > 0) then
            name = "SW"
        else if (dx < 0 .and. dy < 0) then
            name = "NW"
        end if
    end function

end program word_search_rosetta_complete