Task: Semordnilap








VB: Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objInFile = objFSO.OpenTextFile(objFSO.GetParentFolderName(WScript.ScriptFullName) &_
		"\unixdict.txt",1)

Set objUnixDict = CreateObject("Scripting.Dictionary")
Set objSemordnilap = CreateObject("Scripting.Dictionary")

Do Until objInFile.AtEndOfStream
	line = objInFile.ReadLine
	If Len(line) > 1 Then
		objUnixDict.Add line,""
	End If
	reverse_line = StrReverse(line)
	If reverse_line <> line And objUnixDict.Exists(reverse_line) Then
		objSemordnilap.Add line, reverse_line
	End If
Loop	


k = 0
For Each Key In objSemordnilap.Keys
	WScript.StdOut.Write Key & " - " & objSemordnilap.Item(Key)
	WScript.StdOut.WriteLine
	k = k + 1
	If k = 5 Then
		Exit For
	End If
Next

WScript.StdOut.Write "Total Count:  " & objSemordnilap.Count
WScript.StdOut.WriteLine

objInFile.Close
Set objFSO = Nothing
Set objUnixDict = Nothing
Set objSemordnilap = Nothing



Fortran: 

























program Semordnilap
  implicit none
  integer :: i, ios, words, swords
  character(len=24), dimension(32768) :: dictionary, backword
  real, dimension(5) :: harvest
  
  open(7,file='unixdict.txt')
  do words = 1, 32768
    read(7, '(a)', iostat = ios) dictionary(words)
    if (ios .ne. 0) exit
  enddo
  close(7)
  if (iachar(dictionary(words)(1:1)) .eq. 0) words = words-1
  
  call bs(dictionary, words)
  
  
  
  swords = 0
  do i = 1, words
    call reverse(dictionary(i), backword(swords+1))
    if ((binary_search(dictionary, words, backword(swords+1))) &      
      .and. (.not. binary_search(backword, swords, dictionary(i))) &  
      .and. (dictionary(i) .ne. backword(swords+1))) then             
      swords = swords + 1
      call bs(backword, swords)
    endif
  enddo
  call random_number(harvest)
  call reverse('spalindromes', backword(swords+1))
  write(6, *) '5 of ', swords, backword(swords+1)
  write(6,'(5(a/))') (backword(1+int(harvest(i)*(swords-2))), i=1,5)

contains

  subroutine reverse(inp, outp)
    character(len=*), intent(in) :: inp
    character(len=*), intent(inout) :: outp
    integer :: k, L
    L = len_trim(inp)
    do k = 1, L
      outp(L+1-k:L+1-k) = inp(k:k)
    enddo
    do k = L+1, len(outp)
      outp(k:k) = ' '
    enddo
  end subroutine reverse

  subroutine bs(a, n) 
    
    character(len=*),dimension(*),intent(inout) :: a
    integer, intent(in) :: n
    integer :: i, j, k
    logical :: done
    character(len=1) :: t
    do i=n-1, 1, -1
      done = .true.
      do j=1, i
        if (a(j+1) .lt. a(j)) then
          done = .false.
          do k = 1, max(len_trim(a(j+1)), len_trim(a(j)))
            t = a(j+1)(k:k)
            a(j+1)(k:k) = a(j)(k:k)
            a(j)(k:k) = t(1:1)
          enddo
        endif
      enddo
      if (done) return
    enddo
  end subroutine bs

  logical function binary_search(source, n, target)
    character(len=*),dimension(*),intent(in) :: source
    character(len=*),intent(in) :: target
    integer, intent(in) :: n
    integer :: a,m,z
    a = 1
    z = n
    do while (a .lt. z)
      m = a + (z - a) / 2
      if (target .lt. source(m)) then
        z = m-1
      else
        if (m .eq. a) exit
        a = m
      endif
    enddo
    binary_search = (target .eq. source(a)) .or. (target .eq. source(z))
  end function binary_search

end program Semordnilap