164 lines
3.9 KiB
Fortran
164 lines
3.9 KiB
Fortran
program BurrowsWheeler
|
|
implicit none
|
|
|
|
! Main program
|
|
call Test("BANANA")
|
|
call Test("CANAAN")
|
|
call Test("CANCAN")
|
|
call Test("appellee")
|
|
call Test("dogwood")
|
|
call Test("TO BE OR NOT TO BE OR WANT TO BE OR NOT?")
|
|
call Test("SIX.MIXED.PIXIES.SIFT.SIXTY.PIXIE.DUST.BOXES")
|
|
call Test("Four score and 7 years ago, our forefathers set forth on this continent to establish a new nation "//&
|
|
"conceived in liberty and dedicated to he proposition that all men were created equal")
|
|
contains
|
|
! Function to compare rotations
|
|
integer function CompareRotations(input, n, a, b)
|
|
character(len=*), intent(in) :: input
|
|
integer, intent(in) :: n, a, b
|
|
integer :: p, q, nrNotTested
|
|
integer :: i ,k
|
|
|
|
CompareRotations = 0
|
|
p = a
|
|
q = b
|
|
nrNotTested = n
|
|
do
|
|
p = p + 1
|
|
if (p == n) p = 0
|
|
q = q + 1
|
|
if (q == n) q = 0
|
|
i = p + 1
|
|
k = q + 1
|
|
if (input(i:i) == input(k:k)) then
|
|
nrNotTested = nrNotTested - 1
|
|
else if (input(i:i) > input(k:k)) then
|
|
CompareRotations = 1
|
|
exit
|
|
else
|
|
CompareRotations = -1
|
|
exit
|
|
end if
|
|
if (nrNotTested == 0) exit
|
|
end do
|
|
end function CompareRotations
|
|
|
|
! Subroutine to encode the input string
|
|
subroutine Encode(input, encoded, index)
|
|
character(len=*), intent(in) :: input
|
|
character(len=*), intent(out) :: encoded
|
|
integer, intent(out) :: index
|
|
integer :: n, i, j, k, incr, v
|
|
integer, allocatable :: perm(:)
|
|
|
|
n = len(input)
|
|
allocate(perm(0:n-1))
|
|
do j = 0, n - 1
|
|
perm(j) = j
|
|
end do
|
|
|
|
! Shell sort
|
|
incr = 1
|
|
do
|
|
incr = 3 * incr + 1
|
|
if (incr >= n) exit
|
|
end do
|
|
do
|
|
incr = incr / 3
|
|
do i = incr, n - 1
|
|
v = perm(i)
|
|
j = i
|
|
do while (j >= incr)
|
|
if(CompareRotations(input, n, perm(j - incr), v) /= 1)exit
|
|
perm(j) = perm(j - incr)
|
|
j = j - incr
|
|
end do
|
|
perm(j) = v
|
|
end do
|
|
if (incr == 1) exit
|
|
end do
|
|
|
|
! Create the output
|
|
do j = 0, n - 1
|
|
k = perm(j)
|
|
encoded(j + 1:j + 1) = input(k + 1:k + 1)
|
|
if (k == n - 1) index = j
|
|
end do
|
|
|
|
deallocate(perm)
|
|
end subroutine Encode
|
|
|
|
! Function to decode the encoded string
|
|
function Decode(encoded, index) result(decoded)
|
|
character(len=*), intent(in) :: encoded
|
|
integer, intent(in) :: index
|
|
character(len=:), allocatable :: decoded
|
|
integer :: charInfo(0:255)
|
|
integer, allocatable :: perm(:)
|
|
integer :: n, j, k, total, prev
|
|
character :: c
|
|
|
|
n = len(encoded)
|
|
if (n == 0) then
|
|
decoded = ""
|
|
return
|
|
end if
|
|
|
|
charInfo = 0
|
|
do j = 0, n - 1
|
|
c = encoded(j + 1:j + 1)
|
|
charInfo(ichar(c)) = charInfo(ichar(c)) + 1
|
|
end do
|
|
|
|
total = 0
|
|
prev = 0
|
|
do k = 0, 255
|
|
total = total + prev
|
|
prev = charInfo(k)
|
|
charInfo(k) = total
|
|
end do
|
|
|
|
allocate(perm(0:n-1))
|
|
do j = 0, n - 1
|
|
c = encoded(j + 1:j + 1)
|
|
k = charInfo(ichar(c))
|
|
perm(k) = j
|
|
charInfo(ichar(c)) = charInfo(ichar(c)) + 1
|
|
end do
|
|
|
|
allocate(character(len=n) :: decoded)
|
|
k = 0
|
|
j = index
|
|
do
|
|
j = perm(j)
|
|
decoded(k + 1:k + 1) = encoded(j + 1:j + 1)
|
|
k = k + 1
|
|
if (j == index) exit
|
|
end do
|
|
|
|
if (k < n) then
|
|
do j = k, n - 1
|
|
decoded(j + 1:j + 1) = decoded(j - k + 1:j - k + 1)
|
|
end do
|
|
end if
|
|
end function Decode
|
|
|
|
! Subroutine to test the encoding and decoding
|
|
subroutine Test(s)
|
|
character(len=*), intent(in) :: s
|
|
character(len=:), allocatable :: encoded, decoded
|
|
integer :: index
|
|
|
|
print *, ""
|
|
print *, " ", s
|
|
allocate(character(len=len(s)) :: encoded)
|
|
call Encode(s, encoded, index)
|
|
print *, "---> ", encoded
|
|
print *, " index = ", index
|
|
decoded = Decode(encoded, index)
|
|
print *, "---> ", decoded
|
|
deallocate(encoded)
|
|
end subroutine Test
|
|
|
|
end program BurrowsWheeler
|