Crossword

program crossword
implicit none
character*1, allocatable:: grid(:,:)
character*(20) :: words(9)
integer i
, nwords, score,n,casenum, counter, minscore, shuffle_try
allocate(grid(20,20))
cnum: do casenum=1,4
  call readwords
  shuffletry: do shuffle_try=1, 5000
  call shuffle
 ! print*,words(1:nwords)
  grid = ' '
  score=0
  i =1
  counter =0
  wordloop:do
    call addword(grid, words(i),i, n)
    if  (i ==1.or.n > 0)then
      score = score + n
      i =  1+ i
    else if (i<nwords-1) then
      words(i:nwords) = [ words(i+1: nwords), words(i)]
     ! print*, words(i:nwords)
   end if
      counter = counter +1
  !  end if
    if (i> nwords.or. counter > 10) exit wordloop
  end do wordloop
  if (score >= minscore) exit shuffletry
 end do shuffletry
 call printgrid(grid,6)
 call printgrid(grid,11)
 write ( 6, *)score
 write (11,*) score
end do cnum

  contains

subroutine shuffle
character*(:), allocatable :: temp
integer n,i,m
real h
allocate(temp, mold=words(1))
m=nwords
do i=1,m-1
  call random_number(h)
  n=floor((m-i+1)*h)+i
  temp=words(n)
  words(n) =words(i)
  words(i) = temp
end do
end subroutine


subroutine readwords
  read (10,*) nwords, minscore
  read(10,*) words (1: nwords)
  print*, words(1:nwords)
end subroutine

subroutine addword( grid, word,wn, iscore)
  character*1, intent ( inout):: grid(:,:)
  character*(*), intent ( in):: word
  real score
  integer x,y, xdir, ydir, wordlen, best(4), &
       ysize, xsize, yend, xend, iscore
,n,wn
  real  maxscore
  logical fits
  xsize =size (grid,1)
  ysize =size(grid,2)
  wordlen=index(word,' ')-1
  best = 0
  maxscore = 0
  do concurrent (x=1:xsize, y=1:ysize, xdir=1:-1:-1, ydir=1:-1:-1 ,&
       xdir*ydir==0 .AND. xdir+ydir/=0 )
    xend= x+(wordlen-1)*xdir
    if (xend<1.or.xend>xsize) cycle
    yend= y+(wordlen-1)*ydir
    if (yend<1.or.yend>ysize) cycle
    if (wn==1) then
      score=ctrscore(xsize,ysize,x,y,xend,yend)
    else
      call random_number(score)
    end if
    iscore = comboscore(grid,word(1:wordlen),x,y,&
         xdir,ydir)
    if(iscore<0)cycle
    if (score+iscore>maxscore) then
      maxscore=score + iscore
      best=[x,y,xdir,ydir]
    end if
  end do
  x=best(1)
  y=best(2)
  xdir=best(3)
  ydir=best(4)
  iscore = int(maxscore)
  if (iscore<1.and.wn.ne.1) return
  do n=1,wordlen
    grid(x+xdir*(n-1), y+ydir*(n-1)) =word(n:n)
  end do
end subroutine addword

subroutine printgrid(grid,lunit)
character*(1), allocatable :: grid(:,:)
character *(1):: ch
integer i,j,lunit
do i=1, size(grid, 1)
  do j=1, size(grid, 2)
    ch = grid(i,j)
    if (ch == '  ') ch= '.'
    write(lunit,'(a)',advance='NO')ch
  end do
  write (lunit, *)  ' '
end do
end subroutine

pure function ctrscore(xsize, ysize,xstart,ystart,xend, yend)result(score)
    ! position score... penalize for manhattan distance from center of grid
    integer, intent(in) :: xsize, ysize, xstart, ystart, xend, yend
    integer i,x,y
    real xctr, yctr, dist, score
    xctr = (xstart + xend)/2.
    yctr = (ystart + yend)/2.
    score =1. - abs( xsize / 2. - xctr)/xsize -&
         abs( ysize/2. - yctr)/ysize
end function ctrscore

pure function comboscore(grid,word,xstart,ystart,xdir,ydir) &
       result(iscore)
    ! return value is numer of overlapping positions.  if the word
    ! does not fit in the given position, return -1
    character*1, intent(in) :: grid(:,:)
    character*(*),intent(in) ::word
    integer iscore
    integer, intent(in):: xstart,ystart,xdir,ydir
    integer x,y,n, wl

       iscore =0

    wl=len(word)
    do n=1, wl
       x=xstart+(n-1)*xdir
       y=ystart+(n-1)*ydir
       if (grid(x,y) == ' ') cycle
       if (grid(x,y) /= word(n:n)) then
            iscore =-1
            return
       else
          iscore =iscore +1
       end if
    end do
end function comboscore


end program crossword