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