Anagram finder in Fortran 2018

This is the Fortran 2018 implementation of the anagram program. The problem and the solution is described in the main anagram article. Do read that article first.

Also, you may find the C++ article helpful, since it describes member data and functions in some detail, not repeated here. This article describes only the differences between the C++ implementation and this implementation.

This implementation, is an adaption of the Fortran 77 implementation. Fortran 77 does not have a record type. Fortran 95 and later do have a record type, as well as clases, derived types, polymorphism, generic types (templates) and many other modern constructs, but then it is not really Fortran anymore.keys

So, in this implementation I have rearranged the Fortran 77 code, taken advantage of the module concept to avoid COMMON blocks. All GOTO statements are gone. Improved IF and DO statements have made the code locally a little nicer. To show off, I have used the little-known ASSOCIATE statement in a few places

The code should be compatible with all versions of Fortran from Fortran 2003. Only two features require Fortran 2003, and will not work on Fortran 95. These are 1) the ASSOCIATE construct and 2) two functions for accessing command line parameters.


Full source code

module anagram

!!!--- Compile-time constants
  integer,   parameter :: SHORTEST    =        3    ! At least this many characters in an anagram
  integer,   parameter :: LONGEST     =       10    ! At most   - " -
  integer,   parameter :: TEXT_SIZE   =  500*512    ! The size of the letter string
  integer,   parameter :: ACC_SIZE    =       20    ! Max # of accepted entries
  integer,   parameter :: ACC_MINIMUM =        3    ! Fewer than this does not count
  integer,   parameter :: A           = ichar('A')  ! Character code for 'A'
  integer,   parameter :: Z           = ichar('Z')  ! Character code for 'Z'

!!!--- Global variables
  character*(TEXT_SIZE) text
  character*(LONGEST)   unified(1:TEXT_SIZE-SHORTEST+1  )
  integer               words  (1:TEXT_SIZE-SHORTEST+1+1)
  integer               wlen
  integer               nwords
  integer               accepted(1:ACC_SIZE)
  integer               naccepted
  integer               comparisons

contains

!!!----------------------------------------------------------- read_text
  integer function read_text()
    character*(80)     line
    integer            put, n, ix
    character*(255), parameter :: MAP = &
         '----------------------------------------------------------------' // &
         'ABCDEFGHIJKLMNOPQRSTUVWXYZ------ABCDEFGHIJKLMNOPQRSTUVWXYZ------' // &
         '----------------------------------------------------------------' // &
         '---------------------------------------------------------------'

    put = 0
    do
       read (*,'(A80)',end=99) line
       do n = 1, 80, 1
          ix = ichar(line(n:n)) ! We know that there are no null chars in text
          if (MAP(ix:ix) /= '-') then
             if (put > TEXT_SIZE) stop 'Input text too large'
             put = put+1
             text(put:put) = MAP(ix:ix)
          endif
       enddo
    enddo
99  read_text = put
  end function

!!!------------------------------------------------------------ get_key
  character*(LONGEST) function get_key(pos)
    integer pos
    integer lcount(A:Z), n, put, tmp

!!! Count each letter
    lcount  = 0
    do n = pos, pos+wlen-1
       associate (p => lcount(ichar(text(n:n))))
         p = p + 1
       end associate
    enddo
!!! Build key from letter counts
    put = 1
    get_key = ''
    do n = A, Z
       do tmp = 1, lcount(n)
          get_key(put:put) = char(n)
          put = put + 1
       enddo
    enddo
  end function

!!!------------------------------------------------------- compare_words
  integer function compare_words(i1, i2)
    integer i1, i2

    comparisons = comparisons + 1
    associate (pos1 => words(i1), pos2 => words(i2))
      associate (u1 => unified(pos1), u2 => unified(pos2))
        if (u1 > u2) then; compare_words = +1; return; endif
        if (u1 < u2) then; compare_words = -1; return; endif
      end associate
      compare_words = pos1 - pos2
    end associate
  end function

!!!--------------------------------------------------------- add_to_heap
  subroutine add_to_heap(size, value)
    integer size, here, value

    words(size+1) = value
    here = size
    do while (here > 1)
       if (compare_words(size+1, here/2) <= 0) exit
       words(here) = words(here/2)
       here        = here / 2
    enddo
    words(here) = words(size+1)
  end subroutine

!!!----------------------------------------------------------- heap_sort
  subroutine heap_sort()
    integer c12, empty, child, i, w, hsize
    do i = nwords, 2, -1
       w     = words(1)
       hsize = i - 1
       empty = 1
       ! While there are children
       do while (2*empty <= hsize)
          c12 = compare_words(i, 2*empty)
          if (2*empty == hsize) then
             ! There is only one child, bubble if necessary. Done
             if (c12 < 0) words(empty) = words(2*empty)
             exit
          else if (compare_words(i, 2*empty+1) > 0 .and. c12 > 0) then
             ! There are two children, but they are both smaller
             exit
          else
             ! There are two children, and at least one is greater
             child = 2*empty
             if (compare_words(child, child+1) < 0) child = child+1
             words(empty) = words(child)
             empty = child
          endif
       enddo
       words(empty) = words(i)
       words(i) = w
    enddo
  end subroutine

!!!------------------------------------------------------- add_candidate
  subroutine add_candidate(ptr)
    integer ptr,i
    if (naccepted > 0) then
       ! Check for overlap
       if (ptr <= accepted(naccepted)+(wlen-1)) return
       ! Verify that there are no duplicates
       do i = 1, naccepted
          associate (p2 => accepted(i))
            if (text(ptr:ptr+wlen-1) == text(p2:p2+wlen-1)) return
          end associate
       enddo
    endif
    naccepted = naccepted + 1
    accepted(naccepted) = ptr
  end subroutine

!!!-------------------------------------------------------- print_one_result
  subroutine print_one_result()
    integer i, ptr

    write(*,'(I3, ": ")', advance='no') naccepted
    do i = 1, naccepted
       ptr  = accepted(i)
       write(*,'(I5, ": ", A)', advance='no') ptr-1, text(ptr:ptr+wlen-1)
    enddo
    write(*,*)
  end subroutine

!!!------------------------------------------------------------ find_all
  subroutine find_all(text_len, awlen)
    integer         text_len, awlen
    integer         i

    wlen   = awlen
    nwords = text_len - wlen + 1
    do i = 1, nwords
       unified (i) = get_key(i)
       call add_to_heap(i, i)
    enddo

    call heap_sort()
    words(nwords+1) =  nwords + 1
    unified (nwords+1) = 'ZZZZZZZZZZ' !-- Append guard post

    do i=1, nwords
       call add_candidate(words(i))
       if (unified(words(i)) /= unified(words(i+1))) then
          if (naccepted >= ACC_MINIMUM) call print_one_result()
          naccepted = 0
       endif
    enddo
  end subroutine

end module


!!!---------------------------------------------------------------- main
program main
  use anagram, only : read_text, find_all, comparisons, SHORTEST, LONGEST
  integer        from, to
  integer        text_len, wlen, argc
  character*(10) argv1, argv2

  comparisons = 0
  argc = command_argument_count()
  argv1 = '4'
  argv2 = '7'
  if (argc >= 1) call get_command_argument(1, argv1)
  if (argc >= 2) call get_command_argument(2, argv2)
  if (argc == 1) argv2 = argv1

  read(argv1, *) from  !-- Read integer from string
  read(argv2, *) to
  if (to   < from    ) stop '*** empty interval'
  if (to   > LONGEST ) stop '*** to  is too large'
  if (from < SHORTEST) stop '*** from is too small'

  text_len = read_text()
  do wlen = from, to
     if (wlen > from) write(*,*)
     write(*, '("len = ", I0)') wlen
     call find_all(text_len, wlen)
  enddo
  write(*, '("string length = ", I5, ", comparisons = ", I5)') &
       text_len, comparisons
  stop
end

You can reach me by email at “lars dash 7 dot sdu dot se” or by telephone +46 705 189090

View source for the content of this page.