 # Programming challenge (19th century writers)

I’m participating at a C++ course were the instructor gave us a fun programming challenge. I’ve created a modified version in Fortran which is given below. I encourage you to post your full or partial solutions here.

In the C++ version, the “challenging” part is to do everything without a single for loop. It turns out the solutions are incredibly simple by using the right function from the standard template library (STL) and lambdas. E.g. to place the writers born in the 19th century on the top of the table, one solution looks like this:

``````template< typename Table >
void nineteenth_century_first( Table& table )
{
// TODO: Put those born in the 19th century ('c') first
//       without affecting the general order of persons

std::stable_partition(begin(table), end(table),
[](Person const& p){
return p.birth_year >= 1800 && p.birth_year <= 1899;
};
);

}
``````

All the complicated work is done in the `stable_partition` routine.

I’m interested to see how far we can get in Fortran.

``````! writers.f90
!
! Task: Implement the empty subprograms to perform the following operations on a table of persons:
!       1. Print all persons to the screen
!       2. Randomize their order ('r')
!       3. Order them by last name ('l')
!       4. Find the second oldest person as quickly as possible ('2')
!       5. Put those born in the 19th century first ('c')
!       6. Compute the total age of all persons combined ('t')
!
! Inspired by a Modern C++ training course from Klaus Iglberger
!
module person_type

implicit none

type :: person
! TODO: Each person has a firstname, lastname, birth_year,
!       and death year.
end type

contains

subroutine print(table)
type(person), intent(in) :: table(:)

! TODO: Print all persons to the screen
!       The firstname and lastname should be left-aligned within their own
!       columns of width 8 and 13, respectively.
!       Also print the birth year, and age of each person in subsequent columns.

end subroutine

subroutine random_order( table )
type(person), intent(inout) :: table(:)

! TODO: Randomize their order ('r')

end subroutine

subroutine order_by_lastname( table )
type(person), intent(inout) :: table(:)

! TODO: Order them by last name ('l')

end subroutine

subroutine find_second_oldest( table )
type(person), intent(inout) :: table(:)

! TODO: Determine the second oldest person as quickly as possible ('2')
!       Note that you are allowed to change the order of persons.

! print *, "second oldest = ", ... , ", age = ", ...

end subroutine

subroutine nineteenth_century_first( table )
type(person), intent(inout) :: table(:)

! TODO: Put those born in the 19th century ('c') first
!       without affecting the general order of persons

end subroutine

subroutine total_age( table )
type(person), intent(in) :: table(:)

! TODO: Compute the total age of all persons ('t')

! print *, "Total age = ", ...

end subroutine

end module

program main

use person_type

implicit none

type(person), allocatable :: table(:)
character(len=16) :: command

table = [ &
person( "Miguel",  "de Cervantes", 1547, 1616 ), &
person( "Charles", "Dickens",      1812, 1870 ), &
person( "George",  "Orwell",       1903, 1950 ), &
person( "Ernest",  "Hemingway",    1899, 1961 ), &
person( "William", "Shakespear",   1564, 1616 ), &
person( "Leo",     "Tolstoy",      1828, 1910 ), &
person( "Scott",   "Fitzgerald",   1896, 1940 ), &
person( "Franz",   "Kafka",        1883, 1924 ), &
person( "Mark",    "Twain",        1835, 1910 ), &
person( "Roald",   "Dahl",         1916, 1990 ), &
person( "James",   "Joyce",        1882, 1941 ) ]

repeat: do

select case(trim(command))

case('r')
call random_order( table )

case('l')
call order_by_lastname( table )

case('2')
call find_second_oldest( table )

case('c')
call nineteenth_century_first( table )

case('t')
call total_age( table )

case default
exit repeat

end select

call print( table )

end do repeat

end program
``````

To compile the program with gfortran use:

``````gfortran -Wall -o writers writers.f90
``````

If they can use stdlib, I can use fpm(1).
I consider that only fair.

It runs. I had to throw M_random.git together so others could run
that. I will work on cleaning that up, but there is enough there
to work.

``````#!/bin/bash
# init fpm(1) project
fpm new chal --app
cd chal
cat >>fpm.toml <<\EOF
[dependencies]
M_sort        =  {  git  =  "https://github.com/urbanjost/M_sort.git"        }
M_strings     =  {  git  =  "https://github.com/urbanjost/M_strings.git"     }
M_random      =  {  git  =  "https://github.com/urbanjost/M_random.git"      }
EOF
# edit copy of your program in app/main.f90
# build and run program
fpm run
``````
``````! writers.f90
!
! Task: Implement the empty subprograms to perform the following operations on a table of persons:
!       1. Print all persons to the screen
!       2. Randomize their order ('r')
!       3. Order them by last name ('l')
!       4. Find the second oldest person as quickly as possible ('2')
!       5. Put those born in the 19th century first ('c')
!       6. Compute the total age of all persons combined ('t')
!
! Inspired by a Modern C++ training course from Klaus Iglberger
!
module person_type
use M_sort, only : sort_quick_rx
use M_random, only : scramble
use M_strings, only : lower

implicit none

type :: person
! Each person has a firstname, lastname, birth_year, and death year.
character(len=30) :: firstname
character(len=30) :: lastname
integer           :: birth_year
integer           :: death_year
end type

character(len=*),parameter :: g0='(*(g0))'
character(len=*),parameter :: prnt='("|",a8,"|",a13,"| ",i4," | ",i4," |",i3," |")'
contains

subroutine print(table)
! Print all persons to the screen
!       The firstname and lastname should be left-aligned within their own
!       columns of width 8 and 13, respectively.
!       Also print the birth year, and age of each person in subsequent columns.
type(person), intent(in) :: table(:)
integer :: i

write(*,prnt) (&
table(i)%firstname, table(i)%lastname, &
table(i)%birth_year, table(i)%death_year, &
table(i)%death_year-table(i)%birth_year, &
i=1,size(table))
end subroutine

subroutine random_order( table )
! Randomize their order ('r')
type(person), intent(inout) :: table(:)
table=table(scramble(size(table)))
end subroutine

subroutine order_by_lastname( table )
! Order them by last name ('l')
type(person), intent(inout) :: table(:)
integer                     :: indx(size(table))
call sort_quick_rx(lower(table%lastname),indx)
table=table(indx)
end subroutine

subroutine order_by_firstname( table )
! Order them by first name ('f')
type(person), intent(inout) :: table(:)
integer                     :: indx(size(table))
call sort_quick_rx(lower(table%firstname),indx)
table=table(indx)
end subroutine
subroutine order_by_age( table )
! Order them by age ('a')
type(person), intent(inout) :: table(:)
integer                     :: indx(size(table))
call sort_quick_rx(table%death_year-table%birth_year,indx)
table=table(indx)
end subroutine

subroutine order_by_death_year( table )
! Order them by death year ('d')
type(person), intent(inout) :: table(:)
integer                     :: indx(size(table))
call sort_quick_rx(table%death_year,indx)
table=table(indx)
end subroutine

subroutine order_by_birth_year( table )
! Order them by birth name ('b')
type(person), intent(inout) :: table(:)
integer                     :: indx(size(table))
call sort_quick_rx(table%birth_year,indx)
table=table(indx)
end subroutine

subroutine find_second_oldest( table )
! Determine the second oldest person as quickly as possible ('2')
! Note that you are allowed to change the order of persons.
type(person), intent(inout) :: table(:)
integer :: age(size(table))
integer :: i
age=table%death_year-table%birth_year
age(maxloc(age,dim=1))=-1
i=maxloc(age,dim=1)
associate( p => table(i))
print *, "second oldest age = ", age(i)
write(*,prnt) p%firstname, p%lastname, p%birth_year, p%death_year
end associate

end subroutine

subroutine nineteenth_century_first( table )
type(person), intent(inout) :: table(:)

! Put those born in the 19th century ('c') first
! without affecting the general order of persons
! alternatively
end associate
end subroutine

subroutine total_age( table )
! Compute the total age of all persons ('t')
! simplistically assuming your age is death_year-birth_year
type(person), intent(in) :: table(:)
write(*,g0) "Total age = ",sum(table%death_year-table%birth_year)

end subroutine

end module

program main
use person_type

implicit none

type(person), allocatable :: table(:)
character(len=16) :: command
logical :: printtable
integer :: ios

table = [ &
person( "Miguel",  "de Cervantes", 1547, 1616 ), &
person( "Charles", "Dickens",      1812, 1870 ), &
person( "George",  "Orwell",       1903, 1950 ), &
person( "Ernest",  "Hemingway",    1899, 1961 ), &
person( "William", "Shakespeare",  1564, 1616 ), &
person( "Leo",     "Tolstoy",      1828, 1910 ), &
person( "Scott",   "Fitzgerald",   1896, 1940 ), &
person( "Franz",   "Kafka",        1883, 1924 ), &
person( "Mark",    "Twain",        1835, 1910 ), &
person( "Roald",   "Dahl",         1916, 1990 ), &
person( "James",   "Joyce",        1882, 1941 ) ]

repeat: do
printtable=.false.

select case(lower(command(1:1)))

case('2'); call find_second_oldest( table )
case('a'); call order_by_age( table );             printtable=.true.  ! BONUS
case('b'); call order_by_birth_year( table );      printtable=.true.  ! BONUS
case('c'); call nineteenth_century_first( table ); printtable=.true.
case('d'); call order_by_death_year( table );      printtable=.true.  ! BONUS
case('f'); call order_by_firstname( table );       printtable=.true.  ! BONUS
case('l'); call order_by_lastname( table );        printtable=.true.
case('p'); printtable=.true.                                          ! BONUS
case('q'); exit repeat
case('r'); call random_order( table );             printtable=.true.
case('t'); call total_age( table )
case default
write(*,'(a)')[ character(len=80) :: &
'unknown command. enter letter (2,a,b,c,d,f,l,p,q,r,t):', &
'(2)nd oldest, (a)ge, (b)irth date, 19th (c)entury,', &
'(d)death date, (f)irst name, (l)astname, (p)print,', &
'(q)uit, (r)andom order, (t)otal age', &
'' ]
end select
if(printtable)call print( table )

end do repeat

end program
urbanjs@venus:~/github/chal/app\$``````
2 Likes

PS: Shakespear ? I added p, b, d, a, f, q. stdlib has a sort and a case changer. Not sure about something like scramble. Doing it with stdlib might be interesting. Not sure which 19th century meaning you meant; 1801 to 1900 or years from 1900 to 1999. Because there is no year zero in the Gregorian calendar and because people mean different things there maybe you want to change that. Without birth dates ages are approximate, of course. Since there is no “for” in Fortran (ironic, perhaps) not sure what should not be allowed. It is easy to not use a “for” in Fortran! I just avoided DO statements except for the main loop already there. Implied DOs? I used some. WHERE?

Can this not become:

``````table = table(indx)
``````

Fortran allows index arrays. And this would eliminate the implied DO-loop.

Furthermore, you do not need to encode the conditions explicitly in a subroutine:

``````call partitioned( table, (table%birth_year >= 1800 .and. table%birth_year < 1900) )
``````

(with an almost trivial implementation of “partitioned”)

Wrt the C++ code: I always have a hard time to wrap my mind around the syntax, [] and const &, …

1 Like

Shakespeare.

Yes, I was hoping someone would try this. Assume that some persons have very long names, and a fixed-length character string would be wasteful on memory. One could use `character(:), allocatable`, but I think the stdlib `string_type` will have some advantages.

I admit having an erroneous understanding of centuries. The 19th century spans from 1801 to 1900.

Maybe derived-type IO could be used to get rid of this?

I think this is the more elegant solution. Both the index array and implied-do array probably create a temporary table. Now if the table was huge and we low on memory, it might be desirable to do the reshuffling in place. At least I believe that’s how the STL algorithms do it in C++. NAG Library has a function which can be used for this purpose called permute_decompose.
Orthogonal to the issue of in-place shuffling, are

``````table = table(indx)
table(indx) = table
``````

the same?

Yes, the two statements have the same effect. I do not know how a compiler would implement them, though. I can imagine difference occurring there.

Of course, the statements are only efficient in terms of the characters required to write them. They very probably force the use of temporaries. If you want to avoid those, then you need something like the NAG function. It might be possible to hide that behind a user-defined assignment:

``````type(reordering) :: reorder
table = reorder
``````

where you then use the overloaded assignment to do the actual reordering in-place.

1 Like

Personally, I’d also be happy with a subroutine:

``````call order_inplace(table,indx)
``````

I can imagine delegating both the partitioning and reordering to a derived type which accepts a predicate function, or a mask expression. I’m just not sure how to make it sufficiently generic?

Could a generic reorder be achieved with a `class(*)` input argument? After all, at this point we don’t care about the contents of the table items but just that they are moved to the right place.

Edit: with respect to partioning

The `partitioned` subroutine, could use the `true_pos` function of @beliavsky given here.

This was rather clever since the `age` array is temporary anyways. It does require two searches though.

I think it can be made neater with `associate`

``````  subroutine find_second_oldest( table )
! Determine the second oldest person as quickly as possible ('2')
! Note that you are allowed to change the order of persons.
type(person), intent(inout) :: table(:)
integer :: age(size(table))
age = table%death_year - table%birth_year  ! we could also introduce a function
age(maxloc(age,dim=1)) = -1
i = maxloc(age,dim=1)
associate( p => table(i))
print *, "second oldest age = ", age(i)
write(*,prnt) p%firstname, p%lastname, p%birth_year, p%death_year
end associate

end subroutine
``````

Maybe a function like `nmaxloc` would make a nice addition (as well as `nminloc`, `nminval`, `nmaxval`) to stdlib. I’m not sure if these would better be done with partial sorting though, instead of `n` searches?

Even nicer syntax could be achieved with an (impure?) function called `nth_element`:

``````associate( p => table( nth_element(2,age(table),back=.true.) ) )
print *, "second oldest age = ", age(p)
end associate

elemental integer function age(p)
type(person), intent(in) :: p
age = p%death_year - p%birth_year
end function
``````

Same goes here, an associate helps reduce the verbosity:

``````associate(mask => table%birth_year.gt.1900 .and. table%birth_year.lt.2000)
& pack( table, .not. mask ))]
! alternatively
end associate
``````

Maybe a new array transformational function?

``````partition = [pack(x,mask),pack(x,.not. mask)]  ! incomplete example
``````

Some intrinsic functions for the operations done in STL would really enhance the Fortran programming experience.

I made a few of the changes in the original, as you can see the diff by clicking on the history (instead of a second post). Was looking for a way to let anyone edit; not sure if that is the default or not. A lot of the solutions are just a line or two and as mentioned could just be done in the SELECT but it seemed more the intent to stick to the original structure so I did not do that (but it would make the code very short).

Some interesting thoughts on better Fortran or stdlib capabilities. It got deeper and more interesting than I anticipated (which is great!). Tempted to stick this in a github repo and use the commit log to capture some of the changes and start a collection of examples but not feeling that ambitious, and already have about forty repos that need finished already 1 Like

The lecturer in the course is one of the best C++ educators/consultants, so I think he deserves credit for the format of the exercise. It gave me lots of thoughts on how to approach Fortran, but I still have to reflect on them for a while.

Although you could achieve many things with one- or two-liners in the main program, that is not the goal. The idea is to follow Separation of Concerns (SoC). By handling the operations in sub-programs, one can immediately see the main program structure and intent with the repeated do loop and operations, while all the “nasty” details are invisible. It gives the source code a nice sense of cleanliness and symmetry, making it easy to grasp and extend.

In fact the original exercise handled 8 cases and I reduced them for this thread. I was excited to see you added the “bonus” cases back. Well, I have not achieved complete genericity, but with a bit of help, I do have a subroutine that can reverse an array in place without taking particular care about the data type:

``````! reverse_array.f90 --
!     Attempt to create a generic routine that reverses an array - in place
!
module reverse_array
implicit none

contains
subroutine reverse( array, assign )
class(*), dimension(:), intent(inout), pointer     :: array
interface
subroutine assign( a, b )
class(*), intent(out) :: a
class(*), intent(in)  :: b
end subroutine assign
end interface

class(*), allocatable                              :: tmp
integer                                            :: i, j

allocate( tmp, mold=array(1) )

do i = 1,size(array)/2
j        = size(array) + 1 - i
call assign( tmp, array(i) )
call assign( array(i), array(j) )
call assign( array(j), tmp )
enddo
end subroutine reverse
end module reverse_array

! test --
!     Test this implementation
!
program test_reverse_array
use reverse_array

type :: person
! Each person has a firstname, lastname, birth_year, and death year.
character(len=30) :: firstname
character(len=30) :: lastname
integer           :: birth_year
integer           :: death_year
end type

type(person), allocatable, dimension(:), target :: table
class(*), dimension(:), pointer                 :: ptable

table = [ &
person( "Miguel",  "de Cervantes", 1547, 1616 ), &
person( "Charles", "Dickens",      1812, 1870 ), &
person( "George",  "Orwell",       1903, 1950 ), &
person( "Ernest",  "Hemingway",    1899, 1961 ), &
person( "William", "Shakespeare",  1564, 1616 ), &
person( "Leo",     "Tolstoy",      1828, 1910 ), &
person( "Scott",   "Fitzgerald",   1896, 1940 ), &
person( "Franz",   "Kafka",        1883, 1924 ), &
person( "Mark",    "Twain",        1835, 1910 ), &
person( "Roald",   "Dahl",         1916, 1990 ), &
person( "James",   "Joyce",        1882, 1941 ) ]

ptable => table
call reverse( ptable, assign_person )

write(*,'(2a,2i6)') table

contains
subroutine assign_person( a, b )
class(*), intent(out) :: a
class(*), intent(in)  :: b

select type( a )
type is (person)
select type( b )
type is (person)
a = b
end select
end select
end subroutine assign_person
end program test_reverse_array
``````

Out of laziness, I stole, eh, copied, the person data type and the table of persons from the above example.

1 Like

If the code is modified to also work with a `date` derived type, it looks as shown below. The subroutines `assign_person` and `assign_date` are easy to write but also seem like boilerplate. I don’t really understand OOP in any language, but could Fortran be extended so that there was a default `assign` subroutine for two arguments that are objects of the same type? Or is there already a way to write a generic `assign` subroutine?

code
``````! reverse_array.f90 --
!     Attempt to create a generic routine that reverses an array - in place
!
module reverse_array
implicit none

contains
subroutine reverse( array, assign )
class(*), dimension(:), intent(inout), pointer     :: array
interface
subroutine assign( a, b )
class(*), intent(out) :: a
class(*), intent(in)  :: b
end subroutine assign
end interface

class(*), allocatable                              :: tmp
integer                                            :: i, j

allocate( tmp, mold=array(1) )

do i = 1,size(array)/2
j        = size(array) + 1 - i
call assign( tmp, array(i) )
call assign( array(i), array(j) )
call assign( array(j), tmp )
enddo
end subroutine reverse
end module reverse_array

! test --
!     Test this implementation
!
program test_reverse_array
use reverse_array, only: reverse

type :: person
! Each person has a firstname, lastname, birth_year, and death year.
character(len=30) :: firstname
character(len=30) :: lastname
integer           :: birth_year
integer           :: death_year
end type person
!
type :: date
integer :: year, month, day
end type date

type(person), allocatable, target :: table(:)
type(date)  , allocatable, target :: dates(:)
class(*)    , pointer             :: pvec(:)
dates = [date(2021,1,1),date(2020,1,1),date(2019,1,1)]

table = [ &
person( "Miguel",  "de Cervantes", 1547, 1616 ), &
person( "Charles", "Dickens",      1812, 1870 ), &
person( "George",  "Orwell",       1903, 1950 )]

pvec => table
call reverse( pvec, assign_person )

write(*,'(2a,2i6)') table
pvec => dates
write (*,"(' initial:',*(1x,i0))") dates
call reverse( pvec, assign_date )
write (*,"('reversed:',*(1x,i0))") dates
contains
subroutine assign_person( a, b )
class(*), intent(out) :: a
class(*), intent(in)  :: b
select type( a )
type is (person)
select type( b )
type is (person)
a = b
end select
end select
end subroutine assign_person
!
subroutine assign_date(a,b)
class(*), intent(out) :: a
class(*), intent(in)  :: b
select type (a)
type is (date)
select type(b)
type is (date)
a = b
end select
end select
end subroutine assign_date
end program test_reverse_array
``````
ouptut
``````George                        Orwell                          1903  1950
Charles                       Dickens                         1812  1870
Miguel                        de Cervantes                    1547  1616
initial: 2021 1 1 2020 1 1 2019 1 1
reversed: 2019 1 1 2020 1 1 2021 1 1
``````

This sure looks like a template. Would be pretty nice to figure out which “default” templates are needed to work with a family of generic reordering routines.

On a different note, would the following also work?

``````subroutine assign_person( a, b )
class(*), intent(out) :: a
class(*), intent(in)  :: b

if (same_type_as(a,b))  a = b

end subroutine assign_person
``````

Not at present, but maybe you are suggesting a language extension. Gfortran says

``````   96 |     if (same_type_as(a,b))  a = b
|                            1
Error: Nonallocatable variable must not be polymorphic in intrinsic assignment at (1) - check that there is a matching specific subroutine for '=' operator
``````

Yes, that sort of messages is the reason I pass a pointer to the array, instead of the array itself.

Perhaps transfer() can be persuaded to help out?

I guess the `same_type_as` can’t work in this case, because the concrete type is still unknown, and only becomes known in the `select type` block…

Thank you all for the very interesting discussion. I thought of dropping a quick message noting that some of what you have shown here could probably be used as the skeleton for methods of a `stdlib` data frame. Some simple implementations exist already.

1 Like

The conversation got interesting along other avenues so I was not going
to post these changes and interrupt things, but I was making a version
to play with some of the ideas expounded here and along the way decided
to see if I could make procedures conforming to the rules that I had
used from fpm(1) dependencies.

I made a one-line sort(3f) (maybe a known method, but I had not seen
it and was rather pleased with it but have not tested it much yet :>
). What really surprised me, and is related to these discussions is that
when I used it in the form

``````   table( sort(table%lastname) )=table
``````

it worked fine with gfortran(1) and ifort(1), but when I used

``````   table=table( sort(table%lastname)
``````

bizarre errors occurred, including ifort(1) apparently executing it twice.
I don’t want to distract from the discussions here but if anyone has time
to see if that sort(3f) is doing something illegal let me know. I don’t see
it so far.

``````git clone https://github.com/urbanjost/chal.git
cd chal
fpm run chal
# or you can just compile chal/app/main.f90 (no dependencies at the moment)
# as it is just one file; but fpm(1) rules!``````