program main !*****************************************************************************80 ! !! ketel_one() works on the "Ketel One Vodka" problem. ! ! Discussion: ! ! The following challenge appeared in the New York Times, 14 June 2007: ! ! "Dear Ketel One Drinker: Can you make one hundred words, of four letters ! or more, from the letters in Ketel One Vodka?" ! ! Note that the letters cannot appear in a new word more often than they ! appear in the original phrase. So "leek" is OK (there are 3 e's ! available), but "noon" is not (there is only one n). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 April 2021 ! ! Author: ! ! John Burkardt ! implicit none integer ios logical ketel_one character ( len = 80 ) :: ketel_one_file = 'ketel_one.txt' integer ketel_one_number character ( len = 13 ) :: ketel_one_string = 'ketelonevodka' integer, parameter :: ketel_one_unit = 3 logical s_s_subanagram_sorted character ( len = 80 ) string integer string_length integer, parameter :: string_length_min = 4 character ( len = 80 ) string2 character ( len = 80 ) :: word_file = 'wordlist.txt' integer word_long_number integer word_number integer, parameter :: word_unit = 1 call timestamp ( ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ketel_one():' write ( *, '(a)' ) ' FORTRAN90 version' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Work on the "Ketel One Vodka" problem.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The following challenge appeared in ' write ( *, '(a)' ) ' the New York Times, 14 June 2007: ' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' "Dear Ketel One Drinker: ' write ( *, '(a)' ) ' Can you make one hundred words, of four letters' write ( *, '(a)' ) ' or more, from the letters in Ketel One Vodka?"' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Examine a file "' // trim ( word_file ) // '"' write ( *, '(a)' ) ' full of words, and look for "sub-anagrams" ' write ( *, '(a)' ) ' (words whose letters are a subset of the target ones).' write ( *, '(a)' ) ' ' write ( *, '(a,i8)' ) & ' We only consider words of length at least ', string_length_min write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' Copy sub-anagrams to "' // trim ( ketel_one_file ) // '".' word_long_number = 0 word_number = 0 ketel_one_number = 0 ! ! Ascending sort the master string. ! call s_sort_a ( ketel_one_string ) open ( unit = word_unit, file = word_file, status = 'old' ) open ( unit = ketel_one_unit, file = ketel_one_file, status = 'replace' ) ! ! Read a word from the word file, and judge it. ! do read ( word_unit, '(a)', iostat = ios ) string if ( ios /= 0 ) then exit end if word_number = word_number + 1 string_length = len_trim ( string ) if ( string_length_min <= string_length ) then word_long_number = word_long_number + 1 string2 = string call s_low ( string2 ) call s_sort_a ( string2(1:string_length) ) ketel_one = s_s_subanagram_sorted ( ketel_one_string, trim ( string2 ) ) if ( ketel_one ) then write ( ketel_one_unit, '(a)' ) trim ( string ) ketel_one_number = ketel_one_number + 1 end if end if end do close ( unit = word_unit ) close ( unit = ketel_one_unit ) write ( *, * ) ' ' write ( *, * ) ' Number of words checked ', word_number write ( *, * ) ' Number of words that were "long enough" ', word_long_number write ( *, * ) ' Number of sub-anagrams found ', ketel_one_number write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ketel_one():' write ( *, '(a)' ) ' Normal end of execution.' write ( *, '(a)' ) ' ' call timestamp ( ) stop 0 end subroutine ch_low ( ch ) !*****************************************************************************80 ! !! ch_low() lowercases a single character. ! ! Discussion: ! ! Instead of CHAR and ICHAR, we now use the ACHAR and IACHAR functions, ! which guarantee the ASCII collating sequence. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 July 1998 ! ! Author: ! ! John Burkardt ! ! Input: ! ! character CH, the character to be lowercased. ! ! Output: ! ! character CH, the lowercased character. ! implicit none character ch integer i i = iachar ( ch ) if ( 65 <= i .and. i <= 90 ) then ch = achar ( i + 32 ) end if return end subroutine s_low ( s ) !*****************************************************************************80 ! !! s_low() replaces all uppercase letters in a string by lowercase ones. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 July 1998 ! ! Author: ! ! John Burkardt ! ! Input: ! ! character ( len = * ) S, the string to be lowercased. ! ! Output: ! ! character ( len = * ) S, the lowercased string. ! implicit none integer i character ( len = * ) s integer s_length s_length = len_trim ( s ) do i = 1, s_length call ch_low ( s(i:i) ) end do return end function s_s_subanagram_sorted ( s1, s2 ) !*****************************************************************************80 ! !! s_s_subanagram_sorted() determines if S2 is a "subanagram" of S1. ! ! Discussion: ! ! We can assume that S1 and S2 have already been sorted. ! ! S2 is an anagram of S1 if S2 can be formed by permuting the letters ! of S1 ! ! S2 is an subanagram of S1 if S2 can be formed by selecting SOME of ! the letters of S1 and permuting them. ! ! Blanks (trailing or otherwise), punctuation, and capitalization ! are all significant, so be sure to input exactly the information ! you want to check. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 June 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! character ( len = * ) S1, the master string. ! ! character ( len = * ) S2, the second string. ! ! Output: ! ! logical S_S_SUBANAGRAM_SORTED, TRUE if S2 is a subanagram of S1. ! implicit none integer i1 integer i2 logical s_s_subanagram_sorted character ( len = * ) s1 integer s1_length character ( len = * ) s2 integer s2_length s_s_subanagram_sorted = .false. ! ! Sort both. ! ! call s_sort_a ( s1 ) ! call s_sort_a ( s2 ) s1_length = len ( s1 ) s2_length = len ( s2 ) i1 = 0 do i2 = 1, s2_length do i1 = i1 + 1 ! ! Ran out of S1 before finishing. No match is possible. ! if ( s1_length < i1 ) then return end if ! ! The current character in S1 is already greater than the character in S2. ! No match is possible. ! if ( llt ( s2(i2:i2), s1(i1:i1) ) ) then return end if ! ! Found an exact match for current character. Keep going. ! if ( s1(i1:i1) == s2(i2:i2) ) then exit end if ! ! Didn't find a match, but one might be possible if we increase I1. ! end do end do ! ! We matched every character of S2 with something in S1. ! s_s_subanagram_sorted = .true. return end subroutine s_sort_a ( s ) !*****************************************************************************80 ! !! s_sort_a() sorts a string into ascending order. ! ! Discussion: ! ! The string is assumed to be short, and so a simple bubble sort is used. ! ! ALL the characters are sorted, including blanks and punctuation. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 June 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! character ( len = * ) S, the string to be sorted. ! ! Output: ! ! character ( len = * ) S, the sorted string. ! implicit none character c integer i integer j integer k character ( len = * ) s integer s_length s_length = len ( s ) do i = 1, s_length - 1 c = s(i:i) j = i do k = i + 1, s_length if ( iachar ( s(k:k) ) < iachar ( s(j:j) ) ) then j = k end if end do if ( i /= j ) then s(i:i) = s(j:j) s(j:j) = c end if end do return end subroutine timestamp ( ) !*****************************************************************************80 ! !! timestamp() prints the current YMDHMS date as a time stamp. ! ! Example: ! ! May 31 2001 9:45:54.872 AM ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 May 2001 ! ! Author: ! ! John Burkardt ! implicit none character ( len = 8 ) ampm integer d character ( len = 8 ) date integer h integer m integer mm character ( len = 9 ), parameter, dimension(12) :: month = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) integer n integer s character ( len = 10 ) time integer values(8) integer y character ( len = 5 ) zone call date_and_time ( date, time, zone, values ) y = values(1) m = values(2) d = values(3) h = values(5) n = values(6) s = values(7) mm = values(8) if ( h < 12 ) then ampm = 'AM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h < 12 ) then ampm = 'PM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Midnight' else ampm = 'AM' end if end if end if write ( *, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm ) return end