How to resolve the algorithm Flatten a list step by step in the Fortran programming language
Published on 12 May 2024 09:40 PM
How to resolve the algorithm Flatten a list step by step in the Fortran programming language
Table of Contents
Problem Statement
Write a function to flatten the nesting in an arbitrary list of values. Your program should work on the equivalent of this list: Where the correct result would be the list:
Let's start with the solution:
Step by Step solution about How to resolve the algorithm Flatten a list step by step in the Fortran programming language
Source code in the fortran programming language
! input : [[1], 2, [[3, 4], 5], [[[]]], [[[6]]], 7, 8, []]
! flatten : [1, 2, 3, 4, 5, 6, 7, 8 ]
module flat
implicit none
type n
integer :: a
type(n), dimension(:), pointer :: p => null()
logical :: empty = .false.
end type
contains
recursive subroutine del(this)
type(n), intent(inout) :: this
integer :: i
if (associated(this%p)) then
do i = 1, size(this%p)
call del(this%p(i))
end do
end if
end subroutine
function join(xs) result (r)
type(n), dimension(:), target :: xs
type(n) :: r
integer :: i
if (size(xs)>0) then
allocate(r%p(size(xs)), source=xs)
do i = 1, size(xs)
r%p(i) = xs(i)
end do
else
r%empty = .true.
end if
end function
recursive subroutine flatten1(x,r)
integer, dimension (:), allocatable, intent(inout) :: r
type(n), intent(in) :: x
integer, dimension (:), allocatable :: tmp
integer :: i
if (associated(x%p)) then
do i = 1, size(x%p)
call flatten1(x%p(i), r)
end do
elseif (.not. x%empty) then
allocate(tmp(size(r)+1))
tmp(1:size(r)) = r
tmp(size(r)+1) = x%a
call move_alloc(tmp, r)
end if
end subroutine
function flatten(x) result (r)
type(n), intent(in) :: x
integer, dimension(:), allocatable :: r
allocate(r(0))
call flatten1(x,r)
end function
recursive subroutine show(x)
type(n) :: x
integer :: i
if (x%empty) then
write (*, "(a)", advance="no") "[]"
elseif (associated(x%p)) then
write (*, "(a)", advance="no") "["
do i = 1, size(x%p)
call show(x%p(i))
if (i<size(x%p)) then
write (*, "(a)", advance="no") ", "
end if
end do
write (*, "(a)", advance="no") "]"
else
write (*, "(g0)", advance="no") x%a
end if
end subroutine
function fromString(line) result (r)
character(len=*) :: line
type (n) :: r
type (n), dimension(:), allocatable :: buffer, buffer1
integer, dimension(:), allocatable :: stack, stack1
integer :: sp,i0,i,j, a, cur, start
character :: c
if (.not. allocated(buffer)) then
allocate (buffer(5)) ! will be re-allocated if more is needed
end if
if (.not. allocated(stack)) then
allocate (stack(5))
end if
sp = 1; cur = 1; i = 1
do
if ( i > len_trim(line) ) exit
c = line(i:i)
if (c=="[") then
if (sp>size(stack)) then
allocate(stack1(2*size(stack)))
stack1(1:size(stack)) = stack
call move_alloc(stack1, stack)
end if
stack(sp) = cur; sp = sp + 1; i = i+1
elseif (c=="]") then
sp = sp - 1; start = stack(sp)
r = join(buffer(start:cur-1))
do j = start, cur-1
call del(buffer(j))
end do
buffer(start) = r; cur = start+1; i = i+1
elseif (index(" ,",c)>0) then
i = i + 1; continue
elseif (index("-123456789",c)>0) then
i0 = i
do
if ((i>len_trim(line)).or. &
index("1234567890",line(i:i))==0) then
read(line(i0:i-1),*) a
if (cur>size(buffer)) then
allocate(buffer1(2*size(buffer)))
buffer1(1:size(buffer)) = buffer
call move_alloc(buffer1, buffer)
end if
buffer(cur) = n(a); cur = cur + 1; exit
else
i = i+1
end if
end do
else
stop "input corrupted"
end if
end do
end function
end module
program main
use flat
type (n) :: x
x = fromString("[[1], 2, [[3,4], 5], [[[]]], [[[6]]], 7, 8, []]")
write(*, "(a)", advance="no") "input : "
call show(x)
print *
write (*,"(a)", advance="no") "flatten : ["
write (*, "(*(i0,:,:', '))", advance="no") flatten(x)
print *, "]"
end program
SUBROUTINE CRUSH(LIST) !Changes LIST.
Crushes a list holding multi-level entries within [...] to a list of single-level entries. Null entries are purged.
Could escalate to recognising quoted strings as list entries (preserving spaces), not just strings of digits.
CHARACTER*(*) LIST !The text manifesting the list.
INTEGER I,L !Fingers.
LOGICAL LIVE !Scan state.
L = 1 !Output finger. The starting [ is already in place.
LIVE = .FALSE. !A list element is not in progress.
DO I = 2,LEN(LIST) !Scan the characters of the list.
SELECT CASE(LIST(I:I)) !Consider one.
CASE("[","]",","," ") !Punctuation or spacing?
IF (LIVE) THEN !Yes. If previously in an element,
L = L + 1 !Advance the finger,
LIST(L:L) = "," !And place its terminating comma.
LIVE = .FALSE. !Thus the element is finished.
END IF !So much for punctuation and empty space.
CASE DEFAULT !Everything else is an element's content.
LIVE = .TRUE. !So we're in an element.
L = L + 1 !Advance the finger.
LIST(L:L) = LIST(I:I) !And copy the content's character.
END SELECT !Either we're in an element, or, we're not.
END DO !On to the next character.
Completed the crush. At least one ] must have followed the last character of the last element.
LIST(L:L) = "]" !It had provoked a trailing comma. Now it is the ending ].
LIST(L + 1:) = "" !Scrub any tail end, just to be neat.
END !Trailing spaces are the caller's problem.
CHARACTER*88 STUFF !Work area.
STUFF = "[[1], 2, [[3,4], 5], [[[]]], [[[6]]], 7, 8, []]" !The example.
WRITE (6,*) "Original: ",STUFF
CALL CRUSH(STUFF) !Can't be a constant, as it will be changed.
WRITE (6,*) " Crushed: ",STUFF !Behold!
END
You may also check:How to resolve the algorithm Anonymous recursion step by step in the APL programming language
You may also check:How to resolve the algorithm Zhang-Suen thinning algorithm step by step in the Perl programming language
You may also check:How to resolve the algorithm Shell one-liner step by step in the Retro programming language
You may also check:How to resolve the algorithm Anonymous recursion step by step in the Arturo programming language
You may also check:How to resolve the algorithm Gray code step by step in the F# programming language