diff --git a/doc/specs/stdlib_linked_list.md b/doc/specs/stdlib_linked_list.md new file mode 100644 index 000000000..87343ea3f --- /dev/null +++ b/doc/specs/stdlib_linked_list.md @@ -0,0 +1,497 @@ +--- +title: linked lists +--- + +# The `stdlib_linked_list` module + +[TOC] + +## Introduction + +The `stdlib_linked_list` module defines a class and its interface to handle linked lists that +store any type of data. The list may contain data of the same type or of various types. + + +## Types + +### `type(linked_list_type)` + +Linked lists are variables of the type `linked_list_type`. The type provides all the methods +required for storing and retrieving data. + + +## Procedures and methods provided + + + +### `size` - Return the number of data items in the list + +#### Description + +Return the number of data items in the list. + +#### Syntax + +`number = [[stdlib_linked_list(module):list%size]] ()` + +#### Status + +Experimental + +#### Class + +Pure function. + +#### Argument + +None + +#### Result value + +The result is an integer scalar, equal to the number of items currently contained in the list. + +#### Example + +```fortran +{!example/linked_list/example_size.f90!} +``` + + + +### `clear` - Remove all items from the list + +#### Description + +Remove all items from the list + +#### Syntax + +`call [[stdlib_linked_list(module):list%clear]]` + +#### Status + +Experimental + +#### Class + +Subroutine. + +#### Argument + +None + + +#### Example + +```fortran +{!example/linked_list/example_clear.f90!} +``` + + + +### `get` - Get the data item at a given position (node) in the list + +#### Description + +Get the data item at a given position (node) in the list + +#### Syntax + +`item = [[stdlib_linked_list(module):list%get(interface)]] (node_index)` + +#### Status + +Experimental + +#### Class + +Function. + +#### Argument + +- `node_index`: Shall be a scalar integer equal to the position in the list for the new item. + This argument is `intent(in)`. + +#### Result value + +The data item (of type `class(*)`) that is stored at the given position. + +Notes: + +- If the index is 0 or less, the first item in the list is returned. +- If the index is larger than the number of items, the last item in the list is returned. + +#### Example + +```fortran +{!example/linked_list/example_get.f90!} +``` + + + +### `insert` - Insert a new item at a given position (node) in the list + +#### Description + +Insert a new item at a given position (node) in the list + +#### Syntax + +`call [[stdlib_linked_list(module):list%insert(interface)]] (item, node_index)` + +#### Status + +Experimental + +#### Class + +Subroutine. + +#### Argument + +- `item`: Data item to be stored (any type). + This argument is `intent(in)`. +- `node_index`: Shall be an integer scalar equal to the position in the list for the new item. + This argument is `intent(in)`. + +#### Result value + +The list is extended with the new data item at the given position. + +Notes: + +- If the index is 0 or less, the item is stored at the first position. +- If the index is larger than the number of items, it will be appended to the end of the list. + +#### Example + +```fortran +{!example/linked_list/example_insert.f90!} +``` + + + +### `replace` - Replace an existing data by a new item at a given position (node) in the list + +#### Description + +Replace an existing data by a new item at a given position (node) in the list + +#### Syntax + +`call [[stdlib_linked_list(module):list%insert(interface)]] (new_item, node_index)` + +#### Status + +Experimental + +#### Class + +Subroutine. + +#### Argument + +- `new_item`: The new data item to be stored (any type). + This argument is `intent(in)`. +- `node_index`: Shall be an integer scalar equal to the position in the list for the item to be replaced. + This argument is `intent(in)`. + +#### Result value + +The new data item is stored and the existing one removed. + +Notes: + +- If the index is 0 or less, or it is larger than the number of items, nothing is done. + +#### Example + +```fortran +{!example/linked_list/example_replace.f90!} +``` + + + +### `remove` - Remove an items at a given position (node) in the list + +#### Description + +Remove an items at a given position (node) in the list + +#### Syntax + +`call [[stdlib_linked_list(module):list%remove(interface)]] (node_index)` + +#### Status + +Experimental + +#### Class + +Subroutine. + +#### Argument + +- `node_index`: Shall be an integer scalar equal to the position in the list for the item to be removed. + This argument is `intent(in)`. + +#### Result value + +The indicated item has been removed from the list. + +Notes: + +- If the index is 0 or less or the index is larger than the number of items, nothing is done. + +#### Example + +```fortran +{!example/linked_list/example_remove.f90!} +``` + + +### `push` - Append a new item to the end of the list + +#### Description + +Append a new item to the end of the list + +#### Syntax + +`call [[stdlib_linked_list(module):list%push(interface)]] (item)` + +#### Status + +Experimental + +#### Class + +Subroutine. + +#### Argument + +- `item`: Data item to be stored (any type). + This argument is `intent(in)`. + +#### Result value + +The list is extended with the new data item at the tail. + +#### Example + +```fortran +{!example/linked_list/example_push.f90!} +``` + + + +### `pop` - Remove the last item in the list + +#### Description + +Remove the last item in the list + +#### Syntax + +`call [[stdlib_linked_list(module):list%pop(interface)]]` + +#### Status + +Experimental + +#### Class + +Subroutine. + +#### Argument + +None + +#### Result value + +The list item in the list is removed. + +#### Example + +```fortran +{!example/linked_list/example_pop.f90!} +``` + + + +### `reverse` - Reconstruct the list in reverse order + +#### Description + +Reconstruct the list in reverse order + +#### Syntax + +`call [[stdlib_linked_list(module):list%reverse(interface)]]` + +#### Status + +Experimental + +#### Class + +Subroutine. + +#### Argument + +None + +#### Result value + +The list now contains the items in reverse order. + +#### Example + +```fortran +{!example/linked_list/example_reverse.f90!} +``` + + + +### `concat` - Concatenate a list to another list + +#### Description + +Concatenate a list to another list + +#### Syntax + +`call [[stdlib_linked_list(module):list%concat(interface)]] (list_to_concat)` + +#### Status + +Experimental + +#### Class + +Subroutine. + +#### Argument + +- `list_to_concat`: list whose data items are to be appended to the given `linked_list_type` derived type. + this argument is `intent(in)`. + +#### Result value + +The given list is extended with the data items in the second list. The second list remains intact. + +#### Example + +```fortran +{!example/linked_list/example_concat.f90!} +``` + + + +### `absorb` - Absorb a list into another list + +#### Description + +Absorb a list into another list + +#### Syntax + +`call [[stdlib_linked_list(module):list%absorb(interface)]] (list_to_absorb)` + +#### Status + +Experimental + +#### Class + +Subroutine. + +#### Argument + +- `list_to_absorb`: list whose data items will be appended to the given `linked_list_type` derived type. + this argument is `intent(inout)`. + +#### Result value + +The given list is extended with the data items in the second list. The second list is emptied. + +#### Example + +```fortran +{!example/linked_list/example_absorb.f90!} +``` + + + +### `slice` - Return a sublist of a list + +#### Description + +Return a sublist of a list + +#### Syntax + +`sublist = [[stdlib_linked_list(module):list%slice(interface)]] (start, end)` + +#### Status + +Experimental + +#### Class + +Subroutine. + +#### Argument + +- `start`: Shall be an integer scalar equal to the first item to store in the sublist. + this argument is `intent(in)`. +- `end`: Shall be an integer scalar equal to the last item to store in the sublist. + this argument is `intent(in)`. + +#### Result value + +Sublist consisting of the indicated data items. Note that the items themselves are copied from the original +list, so that the two lists are independent. + +#### Example + +```fortran +{!example/linked_list/example_slice.f90!} +``` + + + +### `splice` - Remove a sublist from a list, based on a start and end index. + +#### Description + +Remove a sublist from a list, based on a start and end index. + +#### Syntax + +`call [[stdlib_linked_list(module):list%splice(interface)]] (start, end)` + +#### Status + +Experimental + +#### Class + +Subroutine. + +#### Argument + +- `start`: Shall be an integer scalar equal to the first item to be removed from the list. + this argument is `intent(in)`. +- `end`: Shall be an integer scalar equal to the last item to be removed from the list. + this argument is `intent(in)`. + +#### Result value + +The data items in the given range are removed from the list. + +#### Example + +```fortran +{!example/linked_list/example_splice.f90!} +``` diff --git a/doc/specs/stdlib_stringlist.md b/doc/specs/stdlib_stringlist.md new file mode 100644 index 000000000..a214ce565 --- /dev/null +++ b/doc/specs/stdlib_stringlist.md @@ -0,0 +1,487 @@ +--- +title: stringlist +--- +# Lists of strings + +[TOC] + +## Introduction + +Fortran has supported variable-length strings since the 2003 standard, +but it does not have a native type to handle collections of strings of +different lengths. Such collections are quite useful though and the +language allows us to define a derived type that can handle such +collections. + +The `stdlib_stringlist` module defines a derived type that is capable of +storing a list of strings and of manipulating them. + +Methods include: + +* inserting strings at a given position +* replacing strings at a given position +* deleting a single string or a range of strings +* retrieving a string or a range of strings at a given position +* finding the position of a particular string or a string which contains some substring +* sorting the list + +## Positions in a list of strings + +The module implements what are effectively infinitely long lists: a position is +represented as a positive integer, but there is no "out-of-bound" index. That is, +the following piece of code will simply work: + +```fortran +type(stringlist_type) :: list + +! Add two strings ... +call list%insert( list_head, "The first string" ) +call list%insert( 20, "The last string" ) + +write(*,*) 'The last: ', list%get(list_end) +write(*,*) 'Beyond that: ', list%get(30) +``` +The special position `list_head` represents *the first element*, though a value +of 1 is equivalent. Likewise, the special position `list_end` represents the position +of the *last* element and the position `list_after_end` the position directly after +the last element. You can use these positions to insert a string before the current +first string that is already in the list or to insert after the last string that +has been inserted. + +If you specify a position beyond the last, the `list%get()` method simply returns an empty +string. The same holds for *zero* or *negative* indices. + +For inserting one or more elements, a *zero* or *negative* index is interpreted to mean the first, +an index beyond the last as the one *after* the last - this means effectively that the element is appended. + +If you do: + +```fortran +call list%insert( 1, 'The first string' ) +call list%insert( -10, 'A new first string' ) +``` + +the second inserted string will become the string at the *first* position (1) and all other strings +are shifted by one: + +```none +element 1: 'A new first string' +element 2: 'The first string' +element 3: ... +``` + +If you need the last but one string, you can do so in this way: + +```fortran +write(*,*) 'The last but one: ', list%get(list_end-1) +``` + +So, it is possible to do simple arithmetic. + + +## The derived type: stringlist_type + +### Status + +Experimental + +### Description + +The type holds a small number of components and gives access to a number of procedures, +some of which are implemented as subroutines, others as functions or as operations. + + +### Public `stringlist_type` methods + +The following methods are defined: + +Method | Class | Description +---------------------|------------|------------ +[`delete`](./stdlib_stringlist.html#delete-delete_one_or_more_strings) | Subroutine | Delete one or more strings from the list +[`destroy`](./stdlib_stringlist.html#destroy_destroy_all_strings_in_the_list) | Subroutine | Destroy the contents of the list +[`get`](./stdlib_stringlist.html#get-get_a_single_string_from_a_list) | Function | Get a string from a particular position +[`index`](./stdlib_stringlist.html#index-find_the_index_of_a_particular_string_in_the_list) | Function | Find the index of a string in a list +[`index_sub`](./stdlib_stringlist.html#index_sub-find_the_index_of_a_particular_string_containing_the_given_substring) | Function | Find the index of a string containing a partilcar substring +[`insert`](./stdlib_stringlist.html#insert-insert_one_or_more_strings_after_a_given_position) | Subroutine | Insert a string or a list after a given position +[`length`](./stdlib_stringlist.html#length-return_the_length_of_the_list) | Function | Return the index of the last set position +[`range`](./stdlib_stringlist.html#range-retrieve_a_range_of_string_from_the_list) | Function | Retrieve a range of strings from the list +[`replace`](./stdlib_stringlist.html#replace-replace_one_or_more_strings_between_two_given_positions) | Subroutine | Replace one or more stringa between two positions +[`sort`](./stdlib_stringlist.html#sort-return_a_sorted_list) | Function | Sort the list and return the result as a new list +[`=`](./stdlib_stringlist.html#assign-copy_the_contents_of_a_list) | Assignment | Copy a list +[`//`](./stdlib_stringlist.html#//-concatenate_a_list_with_one_or_more_strings) | Operation | Concatenate a list with a string or concatenate two lists + + +## Details of the methods + +### `delete` - delete one or more strings + +#### Status + +Experimental + +#### Description + +Delete one or more strings from the list via a given position or positions. + +#### Syntax + +`call list % [[stringlist_type(type):delete(bound)]]( first [, last] )` + +#### Class + +Subroutine + +#### Arguments + +`list`: the stringlist variable from which to delete one or more strings + +`first`: the index of the first string to be deleted + +`last` (optional): the index of the last string to be deleted. If left out, only one string is deleted. +If the value is lower than that of `first`, the range is considered to be empty and nothing is deleted. + + +### `destroy` - destroy all strings in the list + +#### Status + +Experimental + +#### Description + +Destroy the entire contents of the list. As the variable holding the list is simply a derived type, the variable +itself is not destroyed. + +#### Syntax + +`call list % [[stringlist_type(type):destroy(bound)]]` + +#### Class + +Subroutine + +#### Arguments + +`list`: the stringlist variable from which to delete all strings + + +### `get` - get a single string from the list + +#### Status + +Experimental + +#### Description + +Get the string at the given position. + +#### Syntax + +`string = list % [[stringlist_type(type):get(bound) ( idx )]]` + +#### Class + +Function + +#### Arguments + +`list`: the stringlist variable to retrieve a string from + +`idx`: the index of the string to be retrieved (see [`the section on positions`](./stdlib_stringlist.html#position-in-a-list-of-strings) + +#### Result value + +A copy of the string stored at the indicated position. + + +### `index` - find the index of a particular string in the list + +#### Status + +Experimental + +#### Description + +Get the position of the first stored string that matches the given string, if `back` is not present or false. If `back` is +false, return the position of the last stored string that matches. Note that trailing blanks are ignored. + +#### Syntax + +`idx = list % [[stringlist_type(type):index(bound) ( string, back )]]` + +#### Class + +Function + +#### Arguments + +`list`: the stringlist variable to retrieve a string from + +`string`: the string to be found in the list + +`back` (optional): logical argument indicating the first occurrence should be returned (`false`) or the last (`true`) + +#### Result value + +The result is either the index of the string in the list or -1 if the string was not found + +#### Example + +Because trailing blanks are ignored, the following calls will give the same result: + +```fortran + write(*,*) list%index( 'A' ) + write(*,*) list%index( 'A ' ) +``` + + +### `index_sub` - find the index of a string containing the given substring in the list + +#### Status + +Experimental + +#### Description + +Get the position of the first stored string that contains the given substring, if `back` is not present or false. If `back` is +false, return the position of the last stored string that contains it. + +#### Syntax + +`idx = list % [[stringlist_type(type):index_sub(bound) ( substring, back )]]` + +#### Class + +Function + +#### Arguments + +`list`: the stringlist variable to retrieve a string from + +`substring`: the substring in question + +`back` (optional): logical argument indicating the first occurrence should be returned (`false`) or the last (`true`) + +#### Result value + +The result is either the index of the string in the list or -1 if the string was not found + + +### `insert` - insert one or more strings after a given position + +#### Status + +Experimental + +#### Description + +Insert one or more strings at a given position. The position may be anything as explained in the section on positions. +A single string may be inserted, another list of strings or a plain array of strings. In all cases trailing blanks, if any, +are retained. + +#### Syntax + +`idx = list % [[stringlist_type(type):insert(bound) ( idx, string )]]` + +#### Class + +Subroutine + +#### Arguments + +`list`: the stringlist variable to insert the string(s) into + +`idx`: the position after which the strings should be inserted + +`string`: the string to be inserted, a list of strings or a plain array of strings + + +### `length` - return the length of the list + +#### Status + +Experimental + +#### Description + +Return the length of the list, defined as the highest index for which a string has been assigned. You can place strings +in any position without needing to fill in the intervening positions. + +#### Syntax + +`length = list % [[stringlist_type(type):length(bound) ()]]` + +#### Class + +Function + +#### Arguments + +`list`: the stringlist variable to retrieve the length from + +#### Result value + +Returns the highest index of a string that has been set. + + + +### `range` - retrieve a range of strings from the list + +#### Status + +Experimental + +#### Description + +Retrieve the strings occurring between the given positions as a new list. + +#### Syntax + +`rangelist = list % [[stringlist_type(type):range(bound) ( first, last )]]` + +#### Class + +Function + +#### Arguments + +`list`: the stringlist variable to insert the string(s) into + +`first`: the position of the first string to be retrieved + +`last`: the position of the last string to be retrieved + +#### Result value + +The result is a new list containing all the strings that appear from the first to the last position, inclusively. + + + +### `replace` - replace one or more strings between two given positions + +#### Status + +Experimental + +#### Description + +Replace one or more strings between two given positions. The new strings may be given as a single string, a list of +strings or a plain array. + +#### Syntax + +`call list % [[stringlist_type(type):replace(bound) ( first, last, string )]]` + +#### Class + +Subroutine + +#### Arguments + +`list`: the stringlist variable to replace the string(s) in + + +`first`: the position of the first string to be retrieved + +`last`: the position of the last string to be retrieved. If only one string needs to be replaced by another string, +then this argument can be left out. + +`string`: the string to be inserted, a list of strings or a plain array of strings + + + +### `sort` - return a sorted list + +#### Status + +Experimental + +#### Description + +Create a new list consisting of the sorted strings of the given list. The strings are sorted according to ASCII, either +in ascending order or descending order. + +#### Syntax + +`sortedlist = list % [[stringlist_type(type):sort(bound) ( ascending )]]` + +#### Class + +Subroutine + +#### Arguments + +`list`: the stringlist variable of which the contents should be copied + +`ascending` (optional): if not present or true, sort the list in ascending order, otherwise descending + +#### Result value + +The contents of the given list is sorted and then stored in the new list. + + +### `=` - copy the contents of a list + +#### Status + +Experimental + +#### Description + +Copy an existing list to a new one. The original list remains unchanged. + +#### Syntax + +`copylist = list` + +#### Class + +Assignment + +#### Operands + +`list`: the stringlist variable to be copied + + + +### `//` - concatenate a list with one or more strings + +#### Status + +Experimental + +#### Description + +Concatenate a list with a string, a list of strings or a plain array + +#### Syntax + +`concatenatedlist = list // string` + +`concatenatedlist = string // list` + +#### Class + +Assignment + +#### Operands + +`list`: the stringlist variable to be concatenated + +`string`: the string to be concatenated, a list of strings or a plain array of strings + +#### Result value + +A stringlist that contains the concatenation of the two operands. + + + +## TODO + +Additional methods: + +filter + +map + +Suggestions from the discussion diff --git a/example/CMakeLists.txt b/example/CMakeLists.txt index 3dd43694f..d71d2f4cc 100644 --- a/example/CMakeLists.txt +++ b/example/CMakeLists.txt @@ -14,6 +14,7 @@ add_subdirectory(hashmaps) add_subdirectory(hash_procedures) add_subdirectory(io) add_subdirectory(linalg) +add_subdirectory(linked_list) add_subdirectory(logger) add_subdirectory(math) add_subdirectory(optval) diff --git a/example/linked_list/CMakeLists.txt b/example/linked_list/CMakeLists.txt new file mode 100644 index 000000000..2428c1f5c --- /dev/null +++ b/example/linked_list/CMakeLists.txt @@ -0,0 +1,15 @@ +include_directories(${CMAKE_CURRENT_LIST_DIR}) + +ADD_EXAMPLE(linked_absorb) +ADD_EXAMPLE(linked_clear) +ADD_EXAMPLE(linked_concat) +ADD_EXAMPLE(linked_get) +ADD_EXAMPLE(linked_insert) +ADD_EXAMPLE(linked_pop) +ADD_EXAMPLE(linked_push) +ADD_EXAMPLE(linked_remove) +ADD_EXAMPLE(linked_replace) +ADD_EXAMPLE(linked_reverse) +ADD_EXAMPLE(linked_size) +ADD_EXAMPLE(linked_slice) +ADD_EXAMPLE(linked_splice) diff --git a/example/linked_list/example_linked_absorb.f90 b/example/linked_list/example_linked_absorb.f90 new file mode 100644 index 000000000..9e493d137 --- /dev/null +++ b/example/linked_list/example_linked_absorb.f90 @@ -0,0 +1,70 @@ +! example_absorb.f90 -- +! Demonstrate the absorb method +! +program example_absorb + use stdlib_linked_list + + implicit none + + type(linked_list_type) :: list, list_to_absorb + + ! + ! Add a few elements to the two lists + ! + call list%insert( "String element", 1 ) + call list%insert( 2, 2 ) + call list%insert( 3.3, 3 ) + + call list_to_absorb%insert( 5, 1 ) + call list_to_absorb%insert( 6, 2 ) + + write(*,*) 'List 1:' + call print_list( list ) + write(*,*) 'List 2:' + call print_list( list_to_absorb ) + + ! + ! Now absorb the second list to the first one + ! + + call list%absorb( list_to_absorb ) + + ! + ! Print the resulting list + ! + write(*,*) 'New list:' + call print_list( list ) + + ! + ! Print the second list (it is untouched) + write(*,*) 'List that was absorbed (should be empty):' + call print_list( list_to_absorb ) + +contains +!include 'linked_list_aux.inc' +subroutine print_list( list ) + type(linked_list_type), intent(in) :: list + + integer :: i + class(*), pointer :: list_item + + do i = 1,list%size() + list_item => list%get(i) + + select type( item => list_item ) + type is (integer) + write(*,*) i, item, ' (integer)' + + type is (real) + write(*,*) i, item, ' (real)' + + type is (character(*)) + write(*,*) i, ' >', item, '< (string)' + + class default + write(*,*) i, ' (type unknown)' + end select + enddo +end subroutine print_list + +end program example_absorb diff --git a/example/linked_list/example_linked_clear.f90 b/example/linked_list/example_linked_clear.f90 new file mode 100644 index 000000000..df7da3b74 --- /dev/null +++ b/example/linked_list/example_linked_clear.f90 @@ -0,0 +1,28 @@ +! example_clear.f90 -- +! Demonstrate the clear method +! +program example_clear + use stdlib_linked_list + + implicit none + + type(linked_list_type) :: list + + ! + ! Add a few elements + ! + call list%insert( "String element", 1 ) + call list%insert( 2, 2 ) + call list%insert( 3.3, 3 ) + + ! + ! Clean up the list + ! + call list%clear() + + ! + ! The program should print 0 + ! + write(*,*) 'Size of the list: ', list%size() + +end program example_clear diff --git a/example/linked_list/example_linked_concat.f90 b/example/linked_list/example_linked_concat.f90 new file mode 100644 index 000000000..181d6d9ec --- /dev/null +++ b/example/linked_list/example_linked_concat.f90 @@ -0,0 +1,70 @@ +! example_concat.f90 -- +! Demonstrate the concat method +! +program example_concat + use stdlib_linked_list + + implicit none + + type(linked_list_type) :: list, list_to_concat + + ! + ! Add a few elements to the two lists + ! + call list%insert( "String element", 1 ) + call list%insert( 2, 2 ) + call list%insert( 3.3, 3 ) + + call list_to_concat%insert( 5, 1 ) + call list_to_concat%insert( 6, 2 ) + + write(*,*) 'List 1:' + call print_list( list ) + write(*,*) 'List 2:' + call print_list( list_to_concat ) + + ! + ! Now concat the second list to the first one + ! + + call list%concat( list_to_concat ) + + ! + ! Print the resulting list + ! + write(*,*) 'New list:' + call print_list( list ) + + ! + ! Print the second list (it is untouched) + write(*,*) 'List that was concatenated (remains intact):' + call print_list( list_to_concat ) + +contains +!include 'linked_list_aux.inc' +subroutine print_list( list ) + type(linked_list_type), intent(in) :: list + + integer :: i + class(*), pointer :: list_item + + do i = 1,list%size() + list_item => list%get(i) + + select type( item => list_item ) + type is (integer) + write(*,*) i, item, ' (integer)' + + type is (real) + write(*,*) i, item, ' (real)' + + type is (character(*)) + write(*,*) i, ' >', item, '< (string)' + + class default + write(*,*) i, ' (type unknown)' + end select + enddo +end subroutine print_list + +end program example_concat diff --git a/example/linked_list/example_linked_get.f90 b/example/linked_list/example_linked_get.f90 new file mode 100644 index 000000000..5162866ca --- /dev/null +++ b/example/linked_list/example_linked_get.f90 @@ -0,0 +1,41 @@ +! example_get.f90 -- +! Demonstrate the get method +! +program example_get + use stdlib_linked_list + + implicit none + + type(linked_list_type) :: list + class(*), pointer :: list_item + integer :: i + + ! + ! Add a few elements + ! + call list%insert( "String element ", 1 ) ! Note the trailing blanks + call list%insert( 2, 2 ) + call list%insert( 3.3, 3 ) + + ! + ! Print the contents of the list + ! + do i = 1,list%size() + list_item => list%get(i) + + select type( item => list_item ) + type is (integer) + write(*,*) i, item, ' (integer)' + + type is (real) + write(*,*) i, item, ' (real)' + + type is (character(*)) + write(*,*) i, ' >', item, '< (string)' + + class default + write(*,*) i, ' (type unknown)' + end select + enddo + +end program example_get diff --git a/example/linked_list/example_linked_insert.f90 b/example/linked_list/example_linked_insert.f90 new file mode 100644 index 000000000..2a15e7094 --- /dev/null +++ b/example/linked_list/example_linked_insert.f90 @@ -0,0 +1,59 @@ +! example_insert.f90 -- +! Demonstrate the insert method +! + +program example_insert + use stdlib_linked_list + + implicit none + + type(linked_list_type) :: list + + ! + ! Add a few elements + ! + call list%insert( "String element", 1 ) + call list%insert( 2, 2 ) + call list%insert( 3.3, 3 ) + + call print_list( list ) + ! + ! Now insert an element in the middle + ! + + call list%insert( "Another string", 2 ) + + ! + ! Print the list + ! + write(*,*) 'New list:' + call print_list( list ) + +contains +!include 'linked_list_aux.inc' +subroutine print_list( list ) + type(linked_list_type), intent(in) :: list + + integer :: i + class(*), pointer :: list_item + + do i = 1,list%size() + list_item => list%get(i) + + select type( item => list_item ) + type is (integer) + write(*,*) i, item, ' (integer)' + + type is (real) + write(*,*) i, item, ' (real)' + + type is (character(*)) + write(*,*) i, ' >', item, '< (string)' + + class default + write(*,*) i, ' (type unknown)' + end select + enddo +end subroutine print_list + +end program example_insert diff --git a/example/linked_list/example_linked_pop.f90 b/example/linked_list/example_linked_pop.f90 new file mode 100644 index 000000000..7e35a73ed --- /dev/null +++ b/example/linked_list/example_linked_pop.f90 @@ -0,0 +1,59 @@ +! example_pop.f90 -- +! Demonstrate the pop method +! +program example_pop + use stdlib_linked_list + + implicit none + + type(linked_list_type) :: list + + ! + ! Add a few elements + ! + call list%insert( "String element", 1 ) + call list%insert( 2, 2 ) + call list%insert( 3.3, 3 ) + + call print_list( list ) + + ! + ! Now pop the last element from the list + ! + + call list%pop + + ! + ! Print the list + ! + write(*,*) 'New list:' + call print_list( list ) + +contains +!include 'linked_list_aux.inc' +subroutine print_list( list ) + type(linked_list_type), intent(in) :: list + + integer :: i + class(*), pointer :: list_item + + do i = 1,list%size() + list_item => list%get(i) + + select type( item => list_item ) + type is (integer) + write(*,*) i, item, ' (integer)' + + type is (real) + write(*,*) i, item, ' (real)' + + type is (character(*)) + write(*,*) i, ' >', item, '< (string)' + + class default + write(*,*) i, ' (type unknown)' + end select + enddo +end subroutine print_list + +end program example_pop diff --git a/example/linked_list/example_linked_push.f90 b/example/linked_list/example_linked_push.f90 new file mode 100644 index 000000000..ec5238a8e --- /dev/null +++ b/example/linked_list/example_linked_push.f90 @@ -0,0 +1,59 @@ +! example_push.f90 -- +! Demonstrate the push method +! +program example_push + use stdlib_linked_list + + implicit none + + type(linked_list_type) :: list + + ! + ! Add a few elements + ! + call list%insert( "String element", 1 ) + call list%insert( 2, 2 ) + call list%insert( 3.3, 3 ) + + call print_list( list ) + + ! + ! Now push a new element to the end + ! + + call list%push( 3 ) + + ! + ! Print the list + ! + write(*,*) 'New list:' + call print_list( list ) + +contains +!include 'linked_list_aux.inc' +subroutine print_list( list ) + type(linked_list_type), intent(in) :: list + + integer :: i + class(*), pointer :: list_item + + do i = 1,list%size() + list_item => list%get(i) + + select type( item => list_item ) + type is (integer) + write(*,*) i, item, ' (integer)' + + type is (real) + write(*,*) i, item, ' (real)' + + type is (character(*)) + write(*,*) i, ' >', item, '< (string)' + + class default + write(*,*) i, ' (type unknown)' + end select + enddo +end subroutine print_list + +end program example_push diff --git a/example/linked_list/example_linked_remove.f90 b/example/linked_list/example_linked_remove.f90 new file mode 100644 index 000000000..609452966 --- /dev/null +++ b/example/linked_list/example_linked_remove.f90 @@ -0,0 +1,59 @@ +! example_remove.f90 -- +! Demonstrate the remove method +! +program example_remove + use stdlib_linked_list + + implicit none + + type(linked_list_type) :: list + + ! + ! Add a few elements + ! + call list%insert( "String element", 1 ) + call list%insert( 2, 2 ) + call list%insert( 3.3, 3 ) + + call print_list( list ) + + ! + ! Now remove the second element + ! + + call list%remove( 2 ) + + ! + ! Print the list + ! + write(*,*) 'New list:' + call print_list( list ) + +contains +!include 'linked_list_aux.inc' +subroutine print_list( list ) + type(linked_list_type), intent(in) :: list + + integer :: i + class(*), pointer :: list_item + + do i = 1,list%size() + list_item => list%get(i) + + select type( item => list_item ) + type is (integer) + write(*,*) i, item, ' (integer)' + + type is (real) + write(*,*) i, item, ' (real)' + + type is (character(*)) + write(*,*) i, ' >', item, '< (string)' + + class default + write(*,*) i, ' (type unknown)' + end select + enddo +end subroutine print_list + +end program example_remove diff --git a/example/linked_list/example_linked_replace.f90 b/example/linked_list/example_linked_replace.f90 new file mode 100644 index 000000000..b816c00cb --- /dev/null +++ b/example/linked_list/example_linked_replace.f90 @@ -0,0 +1,59 @@ +! example_replace.f90 -- +! Demonstrate the replace method +! +program example_replace + use stdlib_linked_list + + implicit none + + type(linked_list_type) :: list + + ! + ! Add a few elements + ! + call list%insert( "String element", 1 ) + call list%insert( 2, 2 ) + call list%insert( 3.3, 3 ) + + call print_list( list ) + + ! + ! Now replace the second element by a string + ! + + call list%replace( "Another string", 2 ) + + ! + ! Print the list + ! + write(*,*) 'New list:' + call print_list( list ) + +contains +!include 'linked_list_aux.inc' +subroutine print_list( list ) + type(linked_list_type), intent(in) :: list + + integer :: i + class(*), pointer :: list_item + + do i = 1,list%size() + list_item => list%get(i) + + select type( item => list_item ) + type is (integer) + write(*,*) i, item, ' (integer)' + + type is (real) + write(*,*) i, item, ' (real)' + + type is (character(*)) + write(*,*) i, ' >', item, '< (string)' + + class default + write(*,*) i, ' (type unknown)' + end select + enddo +end subroutine print_list + +end program example_replace diff --git a/example/linked_list/example_linked_reverse.f90 b/example/linked_list/example_linked_reverse.f90 new file mode 100644 index 000000000..939f5e29c --- /dev/null +++ b/example/linked_list/example_linked_reverse.f90 @@ -0,0 +1,59 @@ +! example_reverse.f90 -- +! Demonstrate the reverse method +! +program example_reverse + use stdlib_linked_list + + implicit none + + type(linked_list_type) :: list + + ! + ! Add a few elements + ! + call list%insert( "String element", 1 ) + call list%insert( 2, 2 ) + call list%insert( 3.3, 3 ) + + call print_list( list ) + + ! + ! Now reverse the whole list + ! + + call list%reverse + + ! + ! Print the list + ! + write(*,*) 'New list:' + call print_list( list ) + +contains +!include 'linked_list_aux.inc' +subroutine print_list( list ) + type(linked_list_type), intent(in) :: list + + integer :: i + class(*), pointer :: list_item + + do i = 1,list%size() + list_item => list%get(i) + + select type( item => list_item ) + type is (integer) + write(*,*) i, item, ' (integer)' + + type is (real) + write(*,*) i, item, ' (real)' + + type is (character(*)) + write(*,*) i, ' >', item, '< (string)' + + class default + write(*,*) i, ' (type unknown)' + end select + enddo +end subroutine print_list + +end program example_reverse diff --git a/example/linked_list/example_linked_size.f90 b/example/linked_list/example_linked_size.f90 new file mode 100644 index 000000000..ef1a4ea61 --- /dev/null +++ b/example/linked_list/example_linked_size.f90 @@ -0,0 +1,23 @@ +! example_size.f90 -- +! Demonstrate the size method +! +program example_size + use stdlib_linked_list + + implicit none + + type(linked_list_type) :: list + + ! + ! Add a few elements + ! + call list%insert( "String element", 1 ) + call list%insert( 2, 2 ) + call list%insert( 3.3, 3 ) + + ! + ! The program should print 3 + ! + write(*,*) 'Size of the list: ', list%size() + +end program example_size diff --git a/example/linked_list/example_linked_slice.f90 b/example/linked_list/example_linked_slice.f90 new file mode 100644 index 000000000..fce6136b3 --- /dev/null +++ b/example/linked_list/example_linked_slice.f90 @@ -0,0 +1,66 @@ +! example_slice.f90 -- +! Demonstrate the slice method +! +program example_slice + use stdlib_linked_list + + implicit none + + type(linked_list_type) :: list, sublist + + ! + ! Add a few elements to the list + ! + call list%insert( "String element", 1 ) + call list%insert( 2, 2 ) + call list%insert( 3.3, 3 ) + call list%insert( 5, 4 ) + call list%insert( 6, 5 ) + + write(*,*) 'Full list:' + call print_list( list ) + + ! + ! Now construct a sublist via the slice method + ! + sublist = list%slice( 2, 4 ) + + ! + ! Print the resulting list + ! + write(*,*) 'Original list:' + call print_list( list ) + + ! + ! Print the second list + write(*,*) 'Sublist:' + call print_list( sublist) + +contains +!include 'linked_list_aux.inc' +subroutine print_list( list ) + type(linked_list_type), intent(in) :: list + + integer :: i + class(*), pointer :: list_item + + do i = 1,list%size() + list_item => list%get(i) + + select type( item => list_item ) + type is (integer) + write(*,*) i, item, ' (integer)' + + type is (real) + write(*,*) i, item, ' (real)' + + type is (character(*)) + write(*,*) i, ' >', item, '< (string)' + + class default + write(*,*) i, ' (type unknown)' + end select + enddo +end subroutine print_list + +end program example_slice diff --git a/example/linked_list/example_linked_splice.f90 b/example/linked_list/example_linked_splice.f90 new file mode 100644 index 000000000..35e517f88 --- /dev/null +++ b/example/linked_list/example_linked_splice.f90 @@ -0,0 +1,64 @@ +! example_splice.f90 -- +! Demonstrate the splice method +! + +program example_splice + use stdlib_linked_list + + implicit none + + type(linked_list_type) :: list + + ! + ! Add a few elements to the list + ! + call list%insert( "String element", 1 ) + call list%insert( 2, 2 ) + call list%insert( 3.3, 3 ) + call list%insert( 5, 1 ) + call list%insert( 6, 2 ) + + write(*,*) 'Full list:' + call print_list( list ) + + ! + ! Now remove a part of the list via the splice method + ! + + write(*,*) 'splicing ...' + call list%splice( 2, 4 ) + + ! + ! Print the resulting list + ! + write(*,*) 'New list:' + call print_list( list ) + +contains +!include 'linked_list_aux.inc' +subroutine print_list( list ) + type(linked_list_type), intent(in) :: list + + integer :: i + class(*), pointer :: list_item + + do i = 1,list%size() + list_item => list%get(i) + + select type( item => list_item ) + type is (integer) + write(*,*) i, item, ' (integer)' + + type is (real) + write(*,*) i, item, ' (real)' + + type is (character(*)) + write(*,*) i, ' >', item, '< (string)' + + class default + write(*,*) i, ' (type unknown)' + end select + enddo +end subroutine print_list + +end program example_splice diff --git a/example/linked_list/linked_list_aux.inc b/example/linked_list/linked_list_aux.inc new file mode 100644 index 000000000..45c71bf70 --- /dev/null +++ b/example/linked_list/linked_list_aux.inc @@ -0,0 +1,27 @@ +! linked_list_aux.f90 -- +! Auxiliary routine for printing the contents of a linked list +! +subroutine print_list( list ) + type(linked_list_type), intent(in) :: list + + integer :: i + class(*), pointer :: list_item + + do i = 1,list%size() + list_item => list%get(i) + + select type( item => list_item ) + type is (integer) + write(*,*) i, item, ' (integer)' + + type is (real) + write(*,*) i, item, ' (real)' + + type is (character(*)) + write(*,*) i, ' >', item, '< (string)' + + class default + write(*,*) i, ' (type unknown)' + end select + enddo +end subroutine print_list diff --git a/example/linked_list/mk.bat b/example/linked_list/mk.bat new file mode 100644 index 000000000..fbfcbd1cf --- /dev/null +++ b/example/linked_list/mk.bat @@ -0,0 +1,17 @@ +gfortran -c ../../src/stdlib_child_list.f90 +gfortran -c ../../src/stdlib_linked_list.f90 +rem gfortran -c linked_list_aux.f90 + +gfortran -o example_linked_size example_linked_size.f90 stdlib_linked_list.o stdlib_child_list.o +gfortran -o example_linked_clear example_linked_clear.f90 stdlib_linked_list.o stdlib_child_list.o +gfortran -o example_linked_get example_linked_get.f90 stdlib_linked_list.o stdlib_child_list.o +gfortran -o example_linked_insert example_linked_insert.f90 stdlib_linked_list.o stdlib_child_list.o +gfortran -o example_linked_replace example_linked_replace.f90 stdlib_linked_list.o stdlib_child_list.o +gfortran -o example_linked_remove example_linked_remove.f90 stdlib_linked_list.o stdlib_child_list.o +gfortran -o example_linked_push example_linked_push.f90 stdlib_linked_list.o stdlib_child_list.o +gfortran -o example_linked_pop example_linked_pop.f90 stdlib_linked_list.o stdlib_child_list.o +gfortran -o example_linked_reverse example_linked_reverse.f90 stdlib_linked_list.o stdlib_child_list.o +gfortran -o example_linked_concat example_linked_concat.f90 stdlib_linked_list.o stdlib_child_list.o +gfortran -o example_linked_absorb example_linked_absorb.f90 stdlib_linked_list.o stdlib_child_list.o +gfortran -o example_linked_slice example_linked_slice.f90 stdlib_linked_list.o stdlib_child_list.o +gfortran -o example_linked_splice example_linked_splice.f90 stdlib_linked_list.o stdlib_child_list.o diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 8a6fe66cc..ef261191e 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -6,14 +6,14 @@ set(fppFiles stdlib_bitsets.fypp stdlib_bitsets_64.fypp stdlib_bitsets_large.fypp - stdlib_hash_32bit.fypp + stdlib_hash_32bit.fypp stdlib_hash_32bit_fnv.fypp - stdlib_hash_32bit_nm.fypp - stdlib_hash_32bit_water.fypp - stdlib_hash_64bit.fypp - stdlib_hash_64bit_fnv.fypp - stdlib_hash_64bit_pengy.fypp - stdlib_hash_64bit_spookyv2.fypp + stdlib_hash_32bit_nm.fypp + stdlib_hash_32bit_water.fypp + stdlib_hash_64bit.fypp + stdlib_hash_64bit_fnv.fypp + stdlib_hash_64bit_pengy.fypp + stdlib_hash_64bit_spookyv2.fypp stdlib_io.fypp stdlib_io_npy.fypp stdlib_io_npy_load.fypp @@ -70,11 +70,13 @@ set(SRC stdlib_ansi_operator.f90 stdlib_ansi_to_string.f90 stdlib_array.f90 + stdlib_child_list.f90 stdlib_error.f90 stdlib_hashmap_wrappers.f90 stdlib_hashmaps.f90 stdlib_hashmap_chaining.f90 stdlib_hashmap_open.f90 + stdlib_linked_list.f90 stdlib_logger.f90 stdlib_sorting_radix_sort.f90 stdlib_system.F90 diff --git a/src/stdlib_child_list.f90 b/src/stdlib_child_list.f90 new file mode 100644 index 000000000..dfd88119e --- /dev/null +++ b/src/stdlib_child_list.f90 @@ -0,0 +1,369 @@ +!> Implementation of a Child list type to hold various types of data. +!> +!> The child list module provides a heterogeneous generic linked list +!> that acts as a basic building block for the linked list module + + +module stdlib_child_list + implicit none + + ! making Node and child_list struct globally available + public:: node_type, child_list_type + + !> Defining Node + !> + !> The purpose of this node is to hold an item + !> and links to previous and next Node. + type node_type + type(node_type), pointer :: next => null() + type(node_type), pointer :: prev => null() + class(*), allocatable :: item + contains + procedure :: clear => node_destroyed + procedure, private :: clear_all => all_nodes_destroyed + end type node_type + + !> Defining Child List + !> + !> This linked list is single-dimensional chain of Nodes. + !> It is a doubly-linked heterogeneous generic list . + type child_list_type + integer, private :: num_nodes = 0 + type(node_type), pointer :: head => null() + type(node_type), pointer :: tail => null() + contains + procedure:: push => push_at_tail + procedure:: insert => insert_at_index + procedure:: pop => pop_node_at_tail + procedure:: remove => remove_node_at_index + procedure:: get => get_node_at_index + procedure:: size => get_length + procedure:: set_size => set_length + procedure:: replace => replace_at_index + procedure:: reverse => reverse_child_list + procedure:: clear => destroy_whole_child_list + end type child_list_type + + contains + + !> Creates a Node that contains 'new_item' as its child + !> + !> Returns the new parent node + pure function initialize_node( new_item ) result( new_node ) + type(node_type) :: new_node + class(*), intent(in), optional :: new_item + + ! allocating new_item to the new node's item + allocate(new_node%item, source=new_item) + end function initialize_node + + !> Delete a node and frees the memory in the item. + subroutine node_destroyed( this_node ) + class(node_type), intent(inout) :: this_node + + !Deallocate it's item + if (allocated(this_node%item)) deallocate(this_node%item) + + !Nullify it's pointers + nullify(this_node%next) + nullify(this_node%prev) + end subroutine node_destroyed + + + pure subroutine all_nodes_destroyed( this_node ) + !Entrada: + class(node_type), intent(inout) :: this_node + !Local: + type(node_type), pointer :: current_node + type(node_type), pointer :: next_node + !Deallocate it's item + current_node = this_node + next_node => current_node%next + do + deallocate(current_node) + if (.not. associated(next_node)) exit + current_node => next_node + next_node => current_node%next + end do + end subroutine all_nodes_destroyed + + + !> Insert 'item' at the tail of the input child list + pure subroutine push_at_tail( this_child_list, item ) + + class(child_list_type), intent(inout) :: this_child_list + class(*), intent(in) :: item + + ! Finding if its a first node or the child_list already have a node + if (associated(this_child_list%tail)) then + allocate(this_child_list%tail%next, source=initialize_node(item)) + this_child_list%tail%next%prev => this_child_list%tail + this_child_list%tail => this_child_list%tail%next + else + allocate(this_child_list%head, source=initialize_node(item)) + this_child_list%tail => this_child_list%head + end if + + this_child_list%num_nodes = this_child_list%num_nodes + 1 + end subroutine push_at_tail + + + !> Insert 'item' at the given 'node_index' of the input child list + pure subroutine insert_at_index( this_child_list, item ,node_index ) + class(child_list_type), intent(inout) :: this_child_list + integer, intent(in) :: node_index + class(*), intent(in) :: item + type(node_type), pointer :: current_node + type(node_type), pointer :: next_node + + integer :: index + + ! This index will be used for iteraing + index = node_index-1 + + ! will insert after tail when the input is more than size of the child list + if(index >=this_child_list%num_nodes) then + call this_child_list%push(item) + return + else if(index <=0) then + ! will insert after tail when the input is more than size of the child list + current_node => this_child_list%head + allocate(this_child_list%head,source = initialize_node(item)) + this_child_list%head%next => current_node + current_node%prev => this_child_list%head + else + current_node => this_child_list%head + do while(index >1) + index = index -1 + current_node => current_node%next + end do + next_node => current_node%next + allocate(current_node%next,source = initialize_node(item)) + current_node%next%prev => current_node + current_node%next%next => next_node + current_node => current_node%next + current_node%next%prev => current_node + end if + this_child_list%num_nodes = this_child_list%num_nodes + 1 + end subroutine insert_at_index + + + !> Removing the last node from the input child list + subroutine pop_node_at_tail( this_child_list ) + + class(child_list_type), intent(inout) :: this_child_list + + type(node_type), pointer:: current_node + + ! return if the size of the child list is 0 + if(this_child_list%num_nodes == 0) return + + + ! poping the last node of the child list + current_node => this_child_list%tail + if (associated(current_node%prev).and.associated(current_node%next)) then + !child_list Node is in mid + current_node%next%prev => current_node%prev + current_node%prev%next => current_node%next + + else if (associated(current_node%prev)) then + !child_list tail + nullify(current_node%prev%next) + this_child_list%tail => current_node%prev + + else if (associated(current_node%next)) then + !child_list head + nullify(current_node%next%prev) + this_child_list%head => current_node%next + else + nullify(this_child_list%head) + nullify(this_child_list%tail) + end if + + !Destroy node content and Free it's memory + call current_node%clear() + deallocate(current_node) + + !Reduce the count by 1 + this_child_list%num_nodes = this_child_list%num_nodes - 1 + end subroutine pop_node_at_tail + + !> Removing the node at the given 'node_index' from the input child list + subroutine remove_node_at_index( this_child_list, node_index ) + + class(child_list_type), intent(inout) :: this_child_list + integer, intent(in):: node_index + type(node_type), pointer:: current_node + + ! This index will be reference for child list + integer:: index + + !iterating through the child_list to reach the nth node + current_node => this_child_list%head + + ! return if the given node index is not in range of 1 to size of linked list + if(node_index<=0) return + if(node_index>this_child_list%num_nodes) return + index = 1 + do while ( associated(current_node) ) + if (index==node_index) then + if (associated(current_node%prev).and.associated(current_node%next)) then + !child_list Node is in mid + current_node%next%prev => current_node%prev + current_node%prev%next => current_node%next + + else if (associated(current_node%prev)) then + !child_list tail + nullify(current_node%prev%next) + this_child_list%tail => current_node%prev + + else if (associated(current_node%next)) then + !child_list head + nullify(current_node%next%prev) + this_child_list%head => current_node%next + else + !only node in list + nullify(this_child_list%head) + nullify(this_child_list%tail) + end if + + !Destroy node content and Free it's memory + call current_node%clear() + deallocate(current_node) + + !Reduce the index by 1 + this_child_list%num_nodes = this_child_list%num_nodes - 1 + return + end if + current_node => current_node%next + index = index+1 + end do + end subroutine remove_node_at_index + + + !> Returns the pointer to the item stored at 'node_index' in the input child list + !> + !> Returns a pointer + function get_node_at_index( this_child_list, node_index ) result (return_item) + + class(child_list_type), intent(inout) :: this_child_list + integer, intent(in):: node_index + class(*), pointer :: return_item + type(node_type), pointer:: current_node + integer:: index + + !iterating through the child_list to reach the nth node + current_node => this_child_list%head + index = 1 + do while ( associated(current_node) ) + + if (index == node_index) then + ! Return the pointer to item stored at specified index + return_item => current_node%item + nullify(current_node) + return + end if + current_node => current_node%next + index = index+1 + + end do + nullify(current_node) + nullify(return_item) + + end function get_node_at_index + + !> Returns the total number of nodes in the input child list + !> + !> Returns an integer + pure function get_length ( this_child_list ) result ( length ) + class(child_list_type), intent(in) :: this_child_list + integer :: length + + length = this_child_list%num_nodes + + end function get_length + + + !> Changes the size of the input child list to 'length' + pure subroutine set_length ( this_child_list, length ) + class(child_list_type), intent(inout) :: this_child_list + integer, intent(in) :: length + + this_child_list%num_nodes = length + + end subroutine set_length + + + + !> Replaces the item stored in node at 'node_index' of the input child list with 'new_item' + pure subroutine replace_at_index( this_child_list, item ,node_index ) + + class(child_list_type), intent(inout) :: this_child_list + integer, intent(in) :: node_index + class(*), intent(in) :: item + type(node_type), pointer :: current_node + integer :: index + + + ! This index will be reference for child list + index = node_index + + ! return if the given node index is not in range of 1 to size of child list + if(index<1 .or. index>this_child_list%num_nodes) return + + + ! Iterating through parent nodes while size of the child list is smaller than index + current_node => this_child_list%head + do while(index>1) + index = index-1 + current_node => current_node%next + end do + current_node%item = item + + end subroutine replace_at_index + + !> Reverses the input child list + pure subroutine reverse_child_list (this_child_list) + class(child_list_type), intent(inout) :: this_child_list + type(node_type), pointer :: temp_node + type(node_type), pointer :: curr_node + + nullify(temp_node) + + ! Swapping head of the child node with tail of the child node + curr_node => this_child_list%head + do while (associated(curr_node)) + temp_node => curr_node%prev + curr_node%prev => curr_node%next + curr_node%next => temp_node + curr_node => curr_node%prev + end do + + temp_node=> this_child_list%head + this_child_list%head => this_child_list%tail + this_child_list%tail => temp_node + + end subroutine reverse_child_list + + !> Destroy the whole given linked list + !> Free the allocated memory + !> Nullify all the variables + subroutine destroy_whole_child_list( this_child_list ) + !Entrada: + class(child_list_type), intent(inout) :: this_child_list + !Local: + type(node_type), pointer:: current_node + + do while (this_child_list%num_nodes>0) + current_node => this_child_list%head + if (associated(current_node%next)) then + nullify(current_node%next%prev) + this_child_list%head => current_node%next + end if + call current_node%clear() + deallocate(current_node) + this_child_list%num_nodes = this_child_list%num_nodes - 1 + end do + + end subroutine destroy_whole_child_list +end module stdlib_child_list diff --git a/src/stdlib_linked_list.f90 b/src/stdlib_linked_list.f90 new file mode 100644 index 000000000..c8d30a2b8 --- /dev/null +++ b/src/stdlib_linked_list.f90 @@ -0,0 +1,786 @@ +!> Implementation of a linked list type to hold various types of data. +!> +!> This module provides a heterogeneous generic linked list. +!> + +module stdlib_linked_list + use stdlib_child_list + implicit none + + ! making Parent_Node and linked_list struct globally available + public :: parent_node_type + public :: linked_list_type + + ! Maximum size of the child linked list + integer, private, parameter :: MAX_SIZE = 10000 + + ! The number of child list's nodes after which splitting of the parent node begins + integer, private, parameter :: SPLIT_POINT = INT(0.9*MAX_SIZE) + + !> Defining Parent Node + !> + !> The purpose of this node is to hold a child list + !> and links to previous and next Parent Node. + type parent_node_type + type(parent_node_type), pointer :: next => null() + type(parent_node_type), pointer :: prev => null() + type(child_list_type) , allocatable :: child + contains + procedure :: size => child_length + procedure :: split => split_into_two_nodes + procedure, private :: destroy => parent_node_destroyed + end type parent_node_type + + !> Defining Linked List + !> + !> This linked list is single-dimensional chain of Parent Nodes. + !> It is a doubly-linked heterogeneous generic list . + type linked_list_type + integer, private :: num_parent_nodes = 0 + integer, private :: total_nodes = 0 + type(Parent_Node_type), pointer :: head => null() + type(Parent_Node_type), pointer :: tail => null() + contains + procedure :: push => append_at_child_tail + procedure :: insert => insert_in_parent_at_index + procedure :: pop => pop_node_at_tail_parent + procedure :: remove => remove_node_at_index_parent + procedure :: get => get_element_at_index_in_parent + procedure :: number_of_parent_nodes => get_number_of_parent_nodes + procedure :: set_number_of_parent_nodes => set_number_of_parent_nodes + procedure :: size => get_total_nodes + procedure :: set_size => set_size_of_list + procedure :: replace => replace_in_parent_at_index + procedure :: reverse => reverse_linked_list + procedure :: clear => clear_whole_linked_list + procedure :: concat => concat_at_end_of_list + procedure :: absorb => absorb_another_list + procedure :: slice => slice_a_part_of_list + procedure :: splice => splice_a_part_of_list + end type linked_list_type + + contains + + !> Creates a Parent Node that contains 'item' as its child + !> + !> Returns the new parent node + pure function initialize_parent_node( item ) result( new_node ) + type(Parent_Node_type) :: new_node + type(child_list_type), intent(in) :: item + + ! allocating item to the new node's child + allocate(new_node%child, source=item) + + end function initialize_parent_node + + + !> Returns the number of nodes stored in the input parent node's child list + pure function child_length( this_parent_node ) result( size ) + class(parent_node_type), intent(in) :: this_parent_node + integer :: size + + size = this_parent_node%child%size() + + end function child_length + + !> Splits the input parent node into two half and + !> connects them with next and prev references + pure subroutine split_into_two_nodes( this_parent_node ) + + ! + class(parent_node_type), intent(inout), target :: this_parent_node + type(Parent_Node_type), pointer :: next_parent_node + type(node_type), pointer :: old_child_tail + type(child_list_type) :: new_child_list + integer :: node_child_size + integer :: i + + + node_child_size = this_parent_node%child%size()/2 + + ! Iterating to the mid point of the list to find tail for old child + i = 1 + old_child_tail => this_parent_node%child%head + do while( i < node_child_size) + i = i+1 + old_child_tail => old_child_tail%next + end do + + ! Associating new child's head and tail + new_child_list%head => old_child_tail%next + new_child_list%tail => this_parent_node%child%tail + + ! Associating old child's tail + this_parent_node%child%tail => old_child_tail + + ! Change the size of the linked lists + call new_child_list%set_size(this_parent_node%child%size()-node_child_size) + call this_parent_node%child%set_size(node_child_size) + + ! Fitting in the new parent node with proper next and prev references + if( associated(this_parent_node%next) ) then + next_parent_node => this_parent_node%next + allocate(this_parent_node%next, source=initialize_parent_node(new_child_list)) + this_parent_node%next%next => next_parent_node + this_parent_node%next%prev => next_parent_node%prev + next_parent_node%prev => this_parent_node%next + else + allocate(this_parent_node%next, source=initialize_parent_node(new_child_list)) + next_parent_node => this_parent_node + next_parent_node%next%prev => next_parent_node + end if + + end subroutine split_into_two_nodes + + + !> Delete a node and frees the memory in the item. + pure subroutine parent_node_destroyed( this_linked_list ) + class(parent_node_type), intent(inout) :: this_linked_list + + !Deallocate it's child + if ( allocated(this_linked_list%child) ) deallocate(this_linked_list%child) + + !Nullify it's pointers + nullify(this_linked_list%next) + nullify(this_linked_list%prev) + + end subroutine parent_node_destroyed + + + !> Insert 'item' at the tail of the input linked list + subroutine append_at_child_tail( this_linked_list, item ) + + class(linked_list_type), intent(inout) :: this_linked_list + class(*), intent(in) :: item + integer :: temp + real :: r + type(child_list_type) :: new_child + + ! Finding if its a first node or the list already have a node + if( this_linked_list%num_parent_nodes == 0 ) then + ! Linked List is empty. Associating head and tail of the input linked list + call new_child%push(item) + allocate(this_linked_list%head, source=initialize_parent_node(new_child)) + this_linked_list%tail => this_linked_list%head + this_linked_list%num_parent_nodes = this_linked_list%num_parent_nodes + 1 + else + ! Checking if the tail node of linked list is needed to break into two parent nodes. + if( this_linked_list%tail%child%size() > SPLIT_POINT ) then + temp = MAX_SIZE-this_linked_list%tail%child%size() + call random_number(r) + if( r*( MAX_SIZE-SPLIT_POINT ) >= temp ) then + call this_linked_list%tail%split() + this_linked_list%num_parent_nodes = this_linked_list%num_parent_nodes + 1 + if( associated(this_linked_list%tail%next) ) this_linked_list%tail => this_linked_list%tail%next + end if + end if + call this_linked_list%tail%child%push(item) + end if + this_linked_list%total_nodes = this_linked_list%total_nodes + 1 + + end subroutine append_at_child_tail + + + !> Insert 'item' at the given 'node_index' of the input parent list + subroutine insert_in_parent_at_index( this_linked_list, item, node_index ) + class(linked_list_type), intent(inout) :: this_linked_list + integer, intent(in):: node_index + class(*), intent(in) :: item + type(Parent_Node_type), pointer:: current_node + real :: r + integer :: index, temp + + ! This index will be reference for child list + index = node_index + current_node => this_linked_list%head + if( this_linked_list%total_nodes == 0 ) then + call this_linked_list%push(item) + return + end if + + ! will insert before head when the input index is less than 1 + if( index <= 0 ) index = 1 + + ! will insert after tail when the input is more than size of the linked list + if( index > this_linked_list%total_nodes ) index = this_linked_list%total_nodes+1 + + ! Iterating through parent nodes while size of the child list is smaller than index + do while( index > current_node%child%size()+1 ) + index = index - current_node%child%size() + current_node => current_node%next + end do + + ! Checking if the current node is needed to split into two parent nodes. + if( current_node%child%size() > (MAX_SIZE-1000) ) then + temp = MAX_SIZE-current_node%child%size() + call random_number(r) + if( r*1000 >= temp ) then + call current_node%split() + this_linked_list%num_parent_nodes = this_linked_list%num_parent_nodes + 1 + if( associated(this_linked_list%tail%next) ) this_linked_list%tail => this_linked_list%tail%next + end if + end if + + do while( index > current_node%child%size()+1 ) + index = index - current_node%child%size() + current_node => current_node%next + end do + + ! Insert 'item' in the child list at index + call current_node%child%insert(item,index) + this_linked_list%total_nodes = this_linked_list%total_nodes + 1 + + end subroutine insert_in_parent_at_index + + + !> Removing the last node from the input linked list + subroutine pop_node_at_tail_parent( this_linked_list ) + + class(linked_list_type), intent(inout) :: this_linked_list + type(Parent_Node_type), pointer :: current_node + + ! return if the size of the linked list is 0 + if( this_linked_list%total_nodes == 0 ) return + + ! pop the last node of the child list of the tail parent node + current_node => this_linked_list%tail + call current_node%child%pop() + + ! if child list of tail parent node is empty, remove the tail parent node + if ( current_node%child%size() == 0 ) then + if ( associated(current_node%prev) .and. associated(current_node%next) ) then + !Parent Node is in mid + current_node%prev%child%tail%next => current_node%next%child%head + current_node%next%child%head%prev => current_node%prev%child%tail + current_node%next%prev => current_node%prev + current_node%prev%next => current_node%next + + else if ( associated(current_node%prev) ) then + !Parent Node is tail + nullify(current_node%prev%child%tail%next) + nullify(current_node%prev%next) + this_linked_list%tail => current_node%prev + + else if ( associated(current_node%next) ) then + !Parent Node is head + nullify(current_node%next%child%head%prev) + nullify(current_node%next%prev) + this_linked_list%head => current_node%next + + else + !Parent Node is the Last Node + nullify(this_linked_list%head) + nullify(this_linked_list%tail) + end if + + !Destroy Paret Node's content and Free it's memory + call current_node%destroy() + deallocate(current_node) + + !Reduce the number of parent nodes by 1 + this_linked_list%num_parent_nodes = this_linked_list%num_parent_nodes - 1 + end if + + this_linked_list%total_nodes = this_linked_list%total_nodes-1 + + end subroutine pop_node_at_tail_parent + + + !> Removing the node at the given 'node_index' from the input linked list + subroutine remove_node_at_index_parent( this_linked_list, node_index ) + + class(linked_list_type), intent(inout) :: this_linked_list + integer, intent(in):: node_index + + type(Parent_Node_type), pointer:: current_node + integer:: index + + ! This index will be reference for child list + index = node_index + current_node => this_linked_list%head + + ! return if the given node index is not in range of 1 to size of linked list + if( node_index <= 0 ) return + if( node_index > this_linked_list%total_nodes ) return + + + ! Iterating through parent nodes while size of the child list is smaller index + do while( index > current_node%child%size() ) + index=index-current_node%child%size() + current_node => current_node%next + end do + call current_node%child%remove(index) + + ! if child list of current parent node is empty, remove the current parent node + if ( current_node%child%size() == 0 ) then + if ( associated(current_node%prev) .and. associated(current_node%next) ) then + !Parent Node is in mid + current_node%prev%child%tail%next => current_node%next%child%head + current_node%next%child%head%prev => current_node%prev%child%tail + current_node%next%prev => current_node%prev + current_node%prev%next => current_node%next + + else if ( associated(current_node%prev) ) then + !Parent Node is tail + nullify(current_node%prev%child%tail%next) + nullify(current_node%prev%next) + this_linked_list%tail => current_node%prev + + else if ( associated(current_node%next) ) then + !Parent Node is head + nullify(current_node%next%child%head%prev) + nullify(current_node%next%prev) + this_linked_list%head => current_node%next + + else + !Parent Node is the Last Node + nullify(this_linked_list%head) + nullify(this_linked_list%tail) + end if + + !Destroy Paret Node's content and Free it's memory + call current_node%destroy() + deallocate(current_node) + + !Reduce the number of parent nodes by 1 + this_linked_list%num_parent_nodes = this_linked_list%num_parent_nodes - 1 + end if + + this_linked_list%total_nodes = this_linked_list%total_nodes-1 + + end subroutine remove_node_at_index_parent + + + !> Returns the pointer to the item stored at 'node_index' in the input linked list + !> + !> Returns a pointer + function get_element_at_index_in_parent( this_linked_list, node_index ) result ( return_item ) + class(linked_list_type), intent(in) :: this_linked_list + integer, intent(in):: node_index + class(*), pointer :: return_item + type(Parent_Node_type), pointer:: current_node + integer:: index + + nullify(return_item) + + ! return if the input linked list is empty + if( this_linked_list%total_nodes == 0 ) return + + ! This index will be reference for child list + index = node_index + + ! Handling out of range index cases + if( index <= 0 ) index = 1 + if( index >= this_linked_list%total_nodes ) index = this_linked_list%total_nodes + + ! Iterating through parent nodes while size of the child list is smaller index + current_node => this_linked_list%head + do while ( associated(current_node) ) + + if( index <= current_node%child%size() ) then + ! Return the pointer to item stored at specified index + return_item => current_node%child%get(index) + return + else + index = index - current_node%child%size() + current_node => current_node%next + end if + end do + nullify(current_node) + + end function get_element_at_index_in_parent + + + !> Returns the number of parent nodes in the input linked list + !> + !> Returns an integer + pure function get_number_of_parent_nodes ( this_linked_list ) result ( length ) + class(linked_list_type), intent(in) :: this_linked_list + integer :: length + + length = this_linked_list%num_parent_nodes + + end function get_number_of_parent_nodes + + + !> Returns the total number of nodes in the input linked list + !> + !> Returns an integer + pure function get_total_nodes ( this_linked_list ) result ( length ) + class(linked_list_type), intent(in) :: this_linked_list + integer :: length + + length = this_linked_list%total_nodes + + end function get_total_nodes + + + !> Changes the size of the input linked list to 'length' + pure subroutine set_size_of_list (this_linked_list, length) + class(linked_list_type), intent(inout) :: this_linked_list + integer, intent(in) :: length + + this_linked_list%total_nodes = length + + end subroutine set_size_of_list + + + !> Changes the number of parent nodes of the input linked list to 'length' + pure subroutine set_number_of_parent_nodes (this_linked_list, length) + class(linked_list_type), intent(inout) :: this_linked_list + integer, intent(in) :: length + + this_linked_list%num_parent_nodes = length + + end subroutine set_number_of_parent_nodes + + !> Replaces the item stored in node at 'node_index' of the input linked list with 'new_item' + pure subroutine replace_in_parent_at_index( this_linked_list, new_item, node_index ) + + class(linked_list_type), intent(inout) :: this_linked_list + integer, intent(in) :: node_index + class(*), intent(in) :: new_item + type(Parent_Node_type), pointer :: current_node + integer :: index + + ! This index will be reference for child list + index = node_index + + ! return if the given node index is not in range of 1 to size of linked list + if( index < 1 .or. index > this_linked_list%total_nodes) return + + ! Iterating through parent nodes while size of the child list is smaller than index + current_node => this_linked_list%head + do while( index > current_node%child%size() ) + index = index-current_node%child%size() + current_node => current_node%next + end do + + call current_node%child%replace(new_item, index) + + end subroutine replace_in_parent_at_index + + + !> Reverses the input linked list + pure subroutine reverse_linked_list ( this_linked_list ) + class(linked_list_type), intent(inout) :: this_linked_list + type(parent_node_type), pointer :: temp_parent_node + type(node_type), pointer :: temp_child_node + type(parent_node_type), pointer :: curr_parent_node + type(node_type), pointer :: curr_child_node + + ! return if the linked list is empty + if( this_linked_list%total_nodes == 0 ) return + + nullify(temp_child_node) + + ! Reversing all the child lists + curr_child_node => this_linked_list%head%child%head + do while ( associated(curr_child_node) ) + temp_child_node => curr_child_node%prev + curr_child_node%prev => curr_child_node%next + curr_child_node%next => temp_child_node + curr_child_node => curr_child_node%prev + end do + + ! Reversing all the Parent nodes and + ! Swapping head of the child node with tail of the child node + nullify(temp_parent_node) + curr_parent_node => this_linked_list%head + do while ( associated(curr_parent_node) ) + + ! Swapping head with tail (child list) + temp_child_node => curr_parent_node%child%head + curr_parent_node%child%head => curr_parent_node%child%tail + curr_parent_node%child%tail => temp_child_node + + ! Reversing Connections of Parent Nodes + temp_parent_node => curr_parent_node%prev + curr_parent_node%prev => curr_parent_node%next + curr_parent_node%next => temp_parent_node + + curr_parent_node => curr_parent_node%prev + end do + + ! Swapping the head of the linked list with tail of the linked list + temp_parent_node=> this_linked_list%head + this_linked_list%head => this_linked_list%tail + this_linked_list%tail => temp_parent_node + + end subroutine reverse_linked_list + + + !> Destroy the whole given linked list + !> Free all the allocated memory + !> Nullify all the variables + subroutine clear_whole_linked_list( this_linked_list ) + class(linked_list_type), intent(inout) :: this_linked_list + type(Parent_Node_type), pointer:: current_node + + !> Iterating through the parent nodes to destroy them + do while ( this_linked_list%num_parent_nodes > 0 ) + + current_node => this_linked_list%head + if ( associated(current_node%next) ) then + nullify(current_node%next%prev) + this_linked_list%head => current_node%next + end if + + !destroy the whole child list + call current_node%child%clear() + + ! Destroy the current node + call current_node%destroy() + deallocate(current_node) + + !Decrement the number of parent nodes + this_linked_list%num_parent_nodes = this_linked_list%num_parent_nodes - 1 + end do + + this_linked_list%total_nodes = 0 + + end subroutine clear_whole_linked_list + + + !> Concat one input linked list (list_to_concat) + !> at the end of other input linked list (this_linked_list) + !> + !> Creates a deep copy of the list_to_concat and + !> appends it at the end of this_linked_list + subroutine concat_at_end_of_list( this_linked_list, list_to_concat ) + class(linked_list_type), intent(inout) :: this_linked_list + type(linked_list_type), intent(inout) :: list_to_concat + type(node_type), pointer :: current_node + + ! Return if list to append is empty + if(list_to_concat%size() == 0) return + + ! Push every item from list_of _concat to this_linked_list + current_node => list_to_concat%head%child%head + do while(associated(current_node)) + call this_linked_list%push(current_node%item) + current_node => current_node%next + end do + + end subroutine concat_at_end_of_list + + !> Absorb one input linked list (list_to_concat) + !> at the end of other input linked list (this_linked_list) + !> + !> Creates a shallow copy of the list_to_concat and + !> appends it at the end of this_linked_list + subroutine absorb_another_list( this_linked_list, list_to_absorb ) + class(linked_list_type), intent(inout) :: this_linked_list + type(linked_list_type), intent(inout) :: list_to_absorb + integer :: total + + ! Return if list to append is empty + if(list_to_absorb%size() == 0) return + + ! if this_linked_list is empty + if(this_linked_list%size() == 0) then + this_linked_list%head => list_to_absorb%head + this_linked_list%tail => list_to_absorb%tail + else + this_linked_list%tail%next => list_to_absorb%head + list_to_absorb%head%prev => this_linked_list%tail + this_linked_list%tail%child%tail%next => list_to_absorb%head%child%head + list_to_absorb%head%child%head%prev => this_linked_list%tail%child%tail + this_linked_list%tail => list_to_absorb%tail + end if + + nullify(list_to_absorb%head) + nullify(list_to_absorb%tail) + + ! Change the size of the linked lists + call this_linked_list%set_size(this_linked_list%size() + list_to_absorb%size()) + total = this_linked_list%number_of_parent_nodes() + list_to_absorb%number_of_parent_nodes() + + call this_linked_list%set_number_of_parent_nodes(total) + call list_to_absorb%set_size(0) + call list_to_absorb%set_number_of_parent_nodes(0) + + end subroutine absorb_another_list + + + !> Returns a linked list that is a slice part of the input linked list + !> Starting from index start till end + !> Returns a linked list + + function slice_a_part_of_list( this_linked_list, start, end ) result ( return_list ) + class(linked_list_type), intent(inout) :: this_linked_list + type(linked_list_type) :: return_list + type(node_type), pointer :: current_node + integer, value :: start + integer, value :: end + integer :: i = 1 + + ! return if the index is out-side range of 1 to size of linked list + if(this_linked_list%size() == 0) return + if(start>end) return + start = max(start,1) + start = min(start,this_linked_list%size()) + end = max(end,1) + end = min(end,this_linked_list%size()) + + + !iterating to find start + current_node => this_linked_list%head%child%head + do while(i < start) + current_node => current_node%next + i = i+1 + end do + + !iterating to find end + do while(associated(current_node) .and. (i <= end)) + call return_list%push(current_node%item) + current_node => current_node%next + i = i+1 + end do + + end function slice_a_part_of_list + + + + subroutine splice_a_part_of_list (this_linked_list, start, end) + class(linked_list_type), intent(inout) :: this_linked_list + type(parent_node_type), pointer :: start_parent_node + type(parent_node_type), pointer :: end_parent_node + type(node_type), pointer :: current_node + type(node_type), pointer :: next_node + type(node_type), pointer :: prev_node + integer, value :: start + integer, value :: end + integer :: ptr + integer :: count + integer :: nodes_in_start_parent_node + integer :: nodes_in_end_parent_node + class(*), pointer :: data + logical :: remove_start + + !nullify every pointer + nullify(start_parent_node) + nullify(end_parent_node) + nullify(current_node) + nullify(next_node) + nullify(prev_node) + + + ! return if the input linked list is empty + if(this_linked_list%size() == 0) return + + ! return if input start is more than input end + if(start>end) return + + ! workaround: delete the first element later (if needed) + if ( start <= 1 ) then + start = 2 + remove_start = .true. + else + remove_start = .false. + endif + + ! handling the out of range index + start = max(start,1) + start = min(start,this_linked_list%size()) + end = max(end,1) + end = min(end,this_linked_list%size()) + + ! destroy the whole llist + if(end == this_linked_list%size() .and. start == 1) then + call this_linked_list%clear() + return + end if + count = 0 + + !iterating through the linked list to find the end parent node + end_parent_node => this_linked_list%head + ptr = 0 + do while(associated(end_parent_node)) + if(ptr+end_parent_node%child%size() > end) exit + ptr = ptr + end_parent_node%child%size() + end_parent_node => end_parent_node%next + count = count+1 + end do + nodes_in_end_parent_node = ptr + + !iterating through the linked list to find the end parent node + if(start /= 1) then + start_parent_node => this_linked_list%head + ptr = 1 + do while(associated(start_parent_node)) + if(ptr+start_parent_node%child%size() >= start) exit + ptr = ptr + start_parent_node%child%size() + start_parent_node => start_parent_node%next + count = count-1 + end do + nodes_in_start_parent_node = ptr-1 + end if + + ! iterating to the find the start_node + ptr = 1 + current_node => this_linked_list%head%child%head + do while(ptr < start) + current_node => current_node%next + ptr = ptr+1 + end do + prev_node => current_node%prev + if(associated(prev_node)) then + end if + + ! iterating to find the last node to splice + do while(associated(current_node) .and. (ptr <= end)) + next_node => current_node%next + if (associated(current_node%prev).and.associated(current_node%next)) then + current_node%next%prev => current_node%prev + current_node%prev%next => current_node%next + else if (associated(current_node%prev)) then + nullify(current_node%prev%next) + else if (associated(current_node%next)) then + nullify(current_node%next%prev) + end if + call current_node%clear() + deallocate(current_node) + current_node => next_node + ptr = ptr+1 + end do + + ! Connecting the parent nodes + if(count == 0) then + if(associated(start_parent_node)) call start_parent_node%child%set_size(start_parent_node%child%size() - (end-start+1)) + else + if(associated(start_parent_node)) then + if(start-nodes_in_start_parent_node-1>0) call start_parent_node%child%set_size(start-nodes_in_start_parent_node-1) + start_parent_node%next => end_parent_node + start_parent_node%child%tail => prev_node + end if + if(associated(end_parent_node)) then + call end_parent_node%child%set_size(end_parent_node%child%size() + nodes_in_end_parent_node - end) + end_parent_node%prev => start_parent_node + end_parent_node%child%head => current_node + end if + end if + + ! setting up new linked list tail if needed + if(end == this_linked_list%size()) then + count = count+1 + this_linked_list%tail => start_parent_node + end if + + ! setting up new linked list head if needed + if(start == 1) then + count = count + 1 + this_linked_list%head => end_parent_node + end if + + ! Changing size of the linked list corrospondingly + call this_linked_list%set_size( this_linked_list%size() - (end - start + 1) ) + if(count>1) call this_linked_list%set_number_of_parent_nodes(this_linked_list%number_of_parent_nodes() - count + 1) + + if ( remove_start ) then + call this_linked_list%remove( 1 ) + endif + + end subroutine splice_a_part_of_list + +end module stdlib_linked_list diff --git a/src/stdlib_stringlist.f90 b/src/stdlib_stringlist.f90 new file mode 100644 index 000000000..570927d7b --- /dev/null +++ b/src/stdlib_stringlist.f90 @@ -0,0 +1,996 @@ +! stdlib_stringlist.f90 -- +! Module for storing and manipulating lists of strings +! The strings may have arbitrary lengths, not necessarily the same +! +! Note: very preliminary +! +! TODO: +! insert( list_end, ... ) in an empty list? +! concatenate two string lists +! +! Not implemented yet: +! insert a list or an array of character strings +! replace a string, list or an array of character strings +! concatenate a list with another list or an array +! +! Limited to implemented routines +! +module stdlib_stringlist + implicit none + + private + public :: stringlist_type + public :: operator(//) + public :: operator(+) + public :: operator(-) + public :: list_end + + type stringlist_index_type + private + logical :: head + integer :: offset + end type stringlist_index_type + + type(stringlist_index_type), parameter :: list_head = stringlist_index_type( .true., 1 ) + type(stringlist_index_type), parameter :: list_end = stringlist_index_type( .false., 0 ) + type(stringlist_index_type), parameter :: list_after_end = stringlist_index_type( .false., 1 ) + + interface operator(+) + module procedure stringlist_index_add + end interface + + interface operator(-) + module procedure stringlist_index_subtract + end interface + + type string_type + character(len=:), allocatable :: value + end type string_type + + type stringlist_type + private + integer :: size = 0 + type(string_type), dimension(:), allocatable :: string + contains + private + procedure, public :: destroy => destroy_list + procedure :: insert_string_idx => insert_string_idx_wrap + procedure :: insert_string_int => insert_string_int_impl + procedure :: insert_stringlist_idx => insert_stringlist_idx_wrap + procedure :: insert_stringlist_int => insert_stringlist_int_impl + procedure :: insert_stringarray_idx => insert_stringarray_idx_wrap + procedure :: insert_stringarray_int => insert_stringarray_int_impl + generic, public :: insert => insert_string_int, insert_string_idx, & + insert_stringlist_int, insert_stringlist_idx, & + insert_stringarray_int, insert_stringarray_idx + procedure :: get_string_int => get_string_int_impl + procedure :: get_string_idx => get_string_idx_wrap + generic, public :: get => get_string_int, get_string_idx + procedure, public :: length => length_list + procedure, public :: sort => sort_list + procedure, public :: index => index_of_string + procedure, public :: index_sub => index_of_substring + procedure :: delete_strings_int_int => delete_strings_int_int_impl + procedure :: delete_strings_idx_int => delete_strings_idx_int_wrap + procedure :: delete_strings_int_idx => delete_strings_int_idx_wrap + procedure :: delete_strings_idx_idx => delete_strings_idx_idx_wrap + generic, public :: delete => delete_strings_int_int, delete_strings_idx_int, & + delete_strings_int_idx, delete_strings_idx_idx + procedure :: range_list_int_int => range_list_int_int_impl + procedure :: range_list_idx_int => range_list_idx_int_wrap + procedure :: range_list_int_idx => range_list_int_idx_wrap + procedure :: range_list_idx_idx => range_list_idx_idx_wrap + generic, public :: range => range_list_int_int, range_list_idx_idx, & + range_list_int_idx, range_list_idx_int + procedure :: replace_string_idx => replace_string_idx_wrap + procedure :: replace_string_int => replace_string_int_impl + procedure :: replace_string_int_int => replace_string_int_int_impl + procedure :: replace_stringarray_int_int => replace_stringarray_int_int_impl + procedure :: replace_stringlist_int_int => replace_stringlist_int_int_impl + procedure :: replace_string_idx_idx => replace_string_idx_idx_wrap + procedure :: replace_stringarray_idx_idx => replace_stringarray_idx_idx_wrap + procedure :: replace_stringlist_idx_idx => replace_stringlist_idx_idx_wrap + procedure :: replace_string_idx_int => replace_string_idx_int_wrap + procedure :: replace_stringarray_idx_int => replace_stringarray_idx_int_wrap + procedure :: replace_stringlist_idx_int => replace_stringlist_idx_int_wrap + procedure :: replace_string_int_idx => replace_string_int_idx_wrap + procedure :: replace_stringarray_int_idx => replace_stringarray_int_idx_wrap + procedure :: replace_stringlist_int_idx => replace_stringlist_int_idx_wrap + generic, public :: replace => replace_string_int_int, replace_stringarray_int_int, & + replace_stringlist_int_int, & + replace_string_idx, replace_string_int, & + replace_string_idx_idx, replace_stringarray_idx_idx, & + replace_stringlist_idx_idx, & + replace_string_idx_int, replace_stringarray_idx_int, & + replace_stringlist_idx_int, & + replace_string_int_idx, replace_stringarray_int_idx, & + replace_stringlist_int_idx + end type stringlist_type + + interface operator(<) + module procedure string_lower + end interface + + interface operator(>) + module procedure string_greater + end interface + + interface operator(==) + module procedure string_equal + end interface + + interface operator(//) + module procedure append_string + module procedure prepend_string + module procedure append_stringlist + module procedure append_stringarray + module procedure prepend_stringarray + end interface +contains + +! stringlist_index_add -- +! Add an integer offset to the special index +! +! Arguments: +! index Special index +! offset Offset to be added +! +function stringlist_index_add( index, offset ) + type(stringlist_index_type), intent(in) :: index + integer, intent(in) :: offset + + type(stringlist_index_type) :: stringlist_index_add + + stringlist_index_add = index + stringlist_index_add%offset = stringlist_index_add%offset + offset +end function stringlist_index_add + +! stringlist_index_subtract -- +! Subtract an integer offset to the special index +! +! Arguments: +! index Special index +! offset Offset to be subtracted +! +function stringlist_index_subtract( index, offset ) + type(stringlist_index_type), intent(in) :: index + integer, intent(in) :: offset + + type(stringlist_index_type) :: stringlist_index_subtract + + stringlist_index_subtract = index + stringlist_index_subtract%offset = stringlist_index_subtract%offset - offset +end function stringlist_index_subtract + +! compare string_type derived types +! Required by sorting functions +! +elemental logical function string_lower( string1, string2 ) + type(string_type), intent(in) :: string1 + type(string_type), intent(in) :: string2 + + string_lower = string1%value < string2%value +end function string_lower + +elemental logical function string_greater( string1, string2 ) + type(string_type), intent(in) :: string1 + type(string_type), intent(in) :: string2 + + string_greater = string1%value > string2%value +end function string_greater + +elemental logical function string_equal( string1, string2 ) + type(string_type), intent(in) :: string1 + type(string_type), intent(in) :: string2 + + string_equal = string1%value == string2%value +end function string_equal + +function append_string( list, string ) + type(stringlist_type), intent(in) :: list + character(len=*), intent(in) :: string + type(stringlist_type) :: append_string + + append_string = list + call append_string%insert( list_after_end, string ) +end function append_string + +function prepend_string( string, list ) + character(len=*), intent(in) :: string + type(stringlist_type), intent(in) :: list + type(stringlist_type) :: prepend_string + + prepend_string = list + call prepend_string%insert( list_head, string ) +end function prepend_string + +function append_stringlist( slist, list ) + type(stringlist_type), intent(in) :: list + type(stringlist_type), intent(in) :: slist + type(stringlist_type) :: append_stringlist + + append_stringlist = list + call append_stringlist%insert( list_after_end, slist ) +end function append_stringlist + +function append_stringarray( list, sarray ) + type(stringlist_type), intent(in) :: list + character(len=*), dimension(:), intent(in) :: sarray + type(stringlist_type) :: append_stringarray + + append_stringarray = list + call append_stringarray%insert( list_after_end, sarray ) +end function append_stringarray + +function prepend_stringarray( sarray, list ) + character(len=*), dimension(:), intent(in) :: sarray + type(stringlist_type), intent(in) :: list + type(stringlist_type) :: prepend_stringarray + + prepend_stringarray = list + call prepend_stringarray%insert( list_head, sarray ) +end function prepend_stringarray + + +! destroy_list -- +! Destroy the contetns of the list +! +! Arguments: +! list The list of strings in question +! +subroutine destroy_list( list ) + class(stringlist_type), intent(inout) :: list + + list%size = 0 + deallocate( list%string ) +end subroutine destroy_list + +! length_list -- +! Return the size (length) of the list +! +! Arguments: +! list The list of strings to retrieve the string from +! +integer function length_list( list ) + class(stringlist_type), intent(in) :: list + + length_list = list%size +end function length_list + +! insert_string -- +! Insert a new string (or an array of strings of another list) into the list +! +! Arguments: +! list The list of strings where the new string(s) should be inserted +! idx Index at which to insert the string +! string The string in question +! +subroutine insert_string_idx_wrap( list, idx, string ) + class(stringlist_type), intent(inout) :: list + type(stringlist_index_type), intent(in) :: idx + character(len=*), intent(in) :: string + + integer :: idxabs + + idxabs = merge( idx%offset, list%size + idx%offset, idx%head ) + + call list%insert( idxabs, string ) +end subroutine insert_string_idx_wrap + +subroutine insert_stringlist_idx_wrap( list, idx, slist ) + class(stringlist_type), intent(inout) :: list + type(stringlist_index_type), intent(in) :: idx + class(stringlist_type), intent(in) :: slist + + integer :: idxabs + + idxabs = merge( idx%offset, list%size + idx%offset, idx%head ) + + call list%insert( idxabs, slist ) +end subroutine insert_stringlist_idx_wrap + +subroutine insert_stringarray_idx_wrap( list, idx, sarray ) + class(stringlist_type), intent(inout) :: list + type(stringlist_index_type), intent(in) :: idx + character(len=*), dimension(:), intent(in) :: sarray + + integer :: idxabs + + idxabs = merge( idx%offset, list%size + idx%offset, idx%head ) + + call list%insert( idxabs, sarray ) +end subroutine insert_stringarray_idx_wrap + +! insert_empty_positions +! Insert a number of positions for new strings +! +! Arguments: +! list The list of strings where the empty positions should be inserted +! idxn Index at which the positions should be inserted +! number Number of positions +! +subroutine insert_empty_positions( list, idxn, number ) + class(stringlist_type), intent(inout) :: list + integer, intent(inout) :: idxn + integer, intent(in) :: number + + integer :: i, inew + integer :: lastidx + type(string_type), dimension(:), allocatable :: new_string + + ! + ! Clip the index between 1 and size+1 + ! + idxn = max( 1, min(list%size+1, idxn ) ) + + ! + ! Check if the array list%string is large enough + ! Make room in any case + ! + if ( .not. allocated(list%string) ) then + allocate(list%string(1) ) + endif + + lastidx = list%size + number + + ! + ! Do we need a copy? + ! + if ( size(list%string) < lastidx ) then + allocate( new_string(lastidx) ) + + do i = 1,idxn-1 + call move_alloc( list%string(i)%value, new_string(i)%value ) + enddo + + do i = idxn, list%size + inew = i + number + call move_alloc( list%string(i)%value, new_string(inew)%value ) + enddo + call move_alloc( new_string, list%string ) + else + do i = idxn, list%size + inew = i + number + call move_alloc( list%string(i)%value, list%string(inew)%value ) + enddo + endif + + list%size = list%size + number + +end subroutine insert_empty_positions + +! insert_string_int_impl -- +! Insert a new string into the list - specific implementation +! +subroutine insert_string_int_impl( list, idx, string ) + class(stringlist_type), intent(inout) :: list + integer, intent(in) :: idx + character(len=*), intent(in) :: string + + integer :: idxn + type(string_type) :: new_element + type(string_type), dimension(:), allocatable :: new_string + + idxn = idx + call insert_empty_positions( list, idxn, 1 ) + + list%string(idxn)%value = string + +end subroutine insert_string_int_impl + +! insert_stringlist_int_impl -- +! Insert a list of strings into the list - specific implementation +! +subroutine insert_stringlist_int_impl( list, idx, slist ) + class(stringlist_type), intent(inout) :: list + integer, intent(in) :: idx + class(stringlist_type), intent(in) :: slist + + integer :: i + integer :: idxn, idxnew + + idxn = idx + call insert_empty_positions( list, idxn, slist%size ) + + do i = 1, slist%size + idxnew = max( 1, idxn ) + i - 1 + list%string(idxnew)%value = slist%string(i)%value + enddo + +end subroutine insert_stringlist_int_impl + +! insert_stringarray_int_impl -- +! Insert an array of strings into the list - specific implementatinon +! +subroutine insert_stringarray_int_impl( list, idx, sarray ) + class(stringlist_type), intent(inout) :: list + integer, intent(in) :: idx + character(len=*), dimension(:), intent(in) :: sarray + + integer :: i + integer :: idxn, idxnew + + idxn = idx + call insert_empty_positions( list, idxn, size(sarray) ) + + do i = 1, size(sarray) + idxnew = max( 1, idxn ) + i - 1 + list%string(idxnew)%value = sarray(i) + enddo + +end subroutine insert_stringarray_int_impl + +! get_string -- +! Get the string at a particular index +! +! Arguments: +! list The list of strings to retrieve the string from +! idx Index after which to insert the string +! +function get_string_idx_wrap( list, idx ) + class(stringlist_type), intent(in) :: list + type(stringlist_index_type), intent(in) :: idx + character(len=:), allocatable :: get_string_idx_wrap + + integer :: idxabs + + idxabs = merge( idx%offset, list%size + idx%offset, idx%head ) + + get_string_idx_wrap = list%get( idxabs ) +end function get_string_idx_wrap + +function get_string_int_impl( list, idx ) + class(stringlist_type), intent(in) :: list + integer, intent(in) :: idx + character(len=:), allocatable :: get_string_int_impl + + integer :: idxnew + + ! + ! Examine the actual index: + ! - if the index is larger than the size, return an empty string + ! - if the index is equal to list_head, interpret it as index 1 + ! - if the index is negative, calculate the absolute index + ! + if ( idx > list%size .or. idx < 1 ) then + get_string_int_impl = '' + else + get_string_int_impl = list%string(idx)%value + endif +end function get_string_int_impl + +! sort_list -- +! Sort the list and return the result as a new list +! +! Arguments: +! list The list of strings to retrieve the string from +! ascending Whether to sort as ascending (true) or not (false) +! +function sort_list( list, ascending ) + class(stringlist_type), intent(in) :: list + logical, intent(in), optional :: ascending + + integer :: i + integer, dimension(:), allocatable :: idx + class(stringlist_type), allocatable :: sort_list + logical :: ascending_order + + ! + ! Allocate and fill the index array, then sort the indices + ! based on the strings + ! + idx = [ (i ,i=1,list%size) ] + + ascending_order = .true. + if ( present(ascending) ) then + ascending_order = ascending + endif + + if ( ascending_order ) then + idx = sort_ascending( idx ) + else + idx = sort_descending( idx ) + endif + + allocate( sort_list ) + allocate( sort_list%string(list%size) ) + + do i = 1,list%size + sort_list%string(i) = list%string(idx(i)) + enddo + sort_list%size = list%size + +contains +recursive function sort_ascending( idx ) result(idxnew) + integer, dimension(:) :: idx + integer, dimension(size(idx)) :: idxnew + + if ( size(idx) > 1 ) then + idxnew = [ sort_ascending( pack( idx, list%string(idx) < list%string(idx(1)) ) ), & + pack( idx, list%string(idx) == list%string(idx(1)) ) , & + sort_ascending( pack( idx, list%string(idx) > list%string(idx(1)) ) ) ] + else + idxnew = idx + endif +end function sort_ascending + +recursive function sort_descending( idx ) result(idxnew) + integer, dimension(:) :: idx + integer, dimension(size(idx)) :: idxnew + + if ( size(idx) > 1 ) then + idxnew = [ sort_descending( pack( idx, list%string(idx) > list%string(idx(1)) ) ), & + pack( idx, list%string(idx) == list%string(idx(1)) ) , & + sort_descending( pack( idx, list%string(idx) < list%string(idx(1)) ) ) ] + else + idxnew = idx + endif +end function sort_descending + +end function sort_list + +! index_of_string -- +! Return the index in the list of a particular string +! +! Arguments: +! list The list of strings in which to search the string +! string The string to be found +! back Whether to search from the end (true) or not (false, default) +! +integer function index_of_string( list, string, back ) + class(stringlist_type), intent(in) :: list + character(len=*), intent(in) :: string + logical, intent(in), optional :: back + + integer :: idx + integer :: i + logical :: start_backwards + + start_backwards = .false. + if ( present(back) ) then + start_backwards = back + endif + + idx = 0 + if ( start_backwards) then + do i = list%size,1,-1 + if ( list%string(i)%value == string ) then + idx = i + exit + endif + enddo + else + do i = 1,list%size + if ( list%string(i)%value == string ) then + idx = i + exit + endif + enddo + endif + + index_of_string = idx +end function index_of_string + +! index_of_substring -- +! Return the index in the list of a string containing a particular substring +! +! Arguments: +! list The list of strings in which to search the string +! substring The substring to be found +! back Whether to search from the end (true) or not (false, default) +! +integer function index_of_substring( list, substring, back ) + class(stringlist_type), intent(in) :: list + character(len=*), intent(in) :: substring + logical, intent(in), optional :: back + + integer :: idx + integer :: i + logical :: start_backwards + + start_backwards = .false. + if ( present(back) ) then + start_backwards = back + endif + + idx = 0 + if ( start_backwards) then + do i = list%size,1,-1 + if ( index(list%string(i)%value, substring) > 0 ) then + idx = i + exit + endif + enddo + else + do i = 1,list%size + if ( index(list%string(i)%value, substring) > 0 ) then + idx = i + exit + endif + enddo + endif + + index_of_substring = idx +end function index_of_substring + +! delete_strings -- +! Delete one or more strings from the list +! +! Arguments: +! list The list of strings in which to search the string +! first The position of the first string to be deleted +! last The position of the last string to be deleted +! +! Note: +! If the range defined by first and last has a zero length or first > last, +! then nothing happens. +! +subroutine delete_strings_idx_idx_wrap( list, first, last ) + class(stringlist_type), intent(inout) :: list + type(stringlist_index_type), intent(in) :: first + type(stringlist_index_type), intent(in) :: last + + integer :: firstpos + integer :: lastpos + + firstpos = merge( first%offset, list%size + first%offset, first%head ) + lastpos = merge( last%offset, list%size + last%offset, last%head ) + + call list%delete( firstpos, lastpos ) +end subroutine delete_strings_idx_idx_wrap + +subroutine delete_strings_int_idx_wrap( list, first, last ) + class(stringlist_type), intent(inout) :: list + integer, intent(in) :: first + type(stringlist_index_type), intent(in) :: last + + integer :: firstpos + integer :: lastpos + + lastpos = merge( last%offset, list%size + last%offset, last%head ) + + call list%delete( firstpos, lastpos ) +end subroutine delete_strings_int_idx_wrap + +subroutine delete_strings_idx_int_wrap( list, first, last ) + class(stringlist_type), intent(inout) :: list + type(stringlist_index_type), intent(in) :: first + integer, intent(in) :: last + + integer :: firstpos + integer :: lastpos + + firstpos = merge( first%offset, list%size + first%offset, first%head ) + + call list%delete( firstpos, lastpos ) +end subroutine delete_strings_idx_int_wrap + +subroutine delete_strings_int_int_impl( list, first, last ) + class(stringlist_type), intent(inout) :: list + integer, intent(in) :: first + integer, intent(in) :: last + + integer :: firstpos + integer :: lastpos + integer :: i + integer :: j + + if ( first > list%size .or. last < 1 ) then + return + endif + + firstpos = max( 1, min(list%size, first ) ) + lastpos = max( 1, min(list%size, last ) ) + + if ( firstpos > lastpos ) then + return + else + do i = lastpos+1,list%size + j = firstpos + i - lastpos - 1 + call move_alloc( list%string(i)%value, list%string(j)%value ) + enddo + do i = list%size - (lastpos-firstpos), list%size + list%string(i)%value = '' + enddo + + list%size = list%size - (lastpos-firstpos + 1) + endif +end subroutine delete_strings_int_int_impl + +! range_list -- +! Return a sublist given by the first and last position +! +! Arguments: +! list The list of strings in which to search the string +! first The position of the first string to be deleted +! last The position of the last string to be deleted +! +! Note: +! If the range defined by first and last has a zero length or first > last, +! then return an empty list +! +function range_list_idx_idx_wrap( list, first, last ) + class(stringlist_type), intent(inout) :: list + type(stringlist_index_type), intent(in) :: first + type(stringlist_index_type), intent(in) :: last + class(stringlist_type), allocatable :: range_list_idx_idx_wrap + + integer :: firstpos + integer :: lastpos + + firstpos = merge( first%offset, list%size + first%offset, first%head ) + lastpos = merge( last%offset, list%size + last%offset, last%head ) + + range_list_idx_idx_wrap = list%range( firstpos, lastpos ) + +end function range_list_idx_idx_wrap + +function range_list_int_idx_wrap( list, first, last ) + class(stringlist_type), intent(inout) :: list + integer, intent(in) :: first + type(stringlist_index_type), intent(in) :: last + class(stringlist_type), allocatable :: range_list_int_idx_wrap + + integer :: lastpos + + lastpos = merge( last%offset, list%size + last%offset, last%head ) + + range_list_int_idx_wrap = list%range( first, lastpos ) + +end function range_list_int_idx_wrap + +function range_list_idx_int_wrap( list, first, last ) + class(stringlist_type), intent(inout) :: list + type(stringlist_index_type), intent(in) :: first + integer, intent(in) :: last + class(stringlist_type), allocatable :: range_list_idx_int_wrap + + integer :: firstpos + + firstpos = merge( first%offset, list%size + first%offset, first%head ) + + range_list_idx_int_wrap = list%range( firstpos, last ) + +end function range_list_idx_int_wrap + +function range_list_int_int_impl( list, first, last ) + class(stringlist_type), intent(inout) :: list + integer, intent(in) :: first + integer, intent(in) :: last + class(stringlist_type), allocatable :: range_list_int_int_impl + + integer :: firstpos + integer :: lastpos + + allocate( range_list_int_int_impl ) + + if ( first > list%size .or. last < 1 ) then + allocate( range_list_int_int_impl%string(0) ) + return + endif + + firstpos = max( 1, min(list%size, first ) ) + lastpos = max( 1, min(list%size, last ) ) + + if ( firstpos > lastpos ) then + allocate( range_list_int_int_impl%string(0) ) + return + else + range_list_int_int_impl%size = lastpos - firstpos + 1 + range_list_int_int_impl%string = list%string(firstpos:lastpos) + endif +end function range_list_int_int_impl + + +! replace_string -- +! Replace a string in the list +! +! Arguments: +! list The list of strings in which to replace a string (or a range of strings) +! first First index of the string(s) to be replaced +! last Last index of the string(s) to be replaced +! string The string in question (array of strings or another string list) +! +! Note: +! For convenience a version that simply replaces a single string is provided +! +subroutine replace_string_idx_wrap( list, idx, string ) + class(stringlist_type), intent(inout) :: list + type(stringlist_index_type), intent(in) :: idx + character(len=*), intent(in) :: string + + integer :: idxpos + + idxpos = merge( idx%offset, list%size + idx%offset, idx%head ) + + call list%replace( idxpos, string ) +end subroutine replace_string_idx_wrap + +subroutine replace_string_int_impl( list, idx, string ) + class(stringlist_type), intent(inout) :: list + integer, intent(in) :: idx + character(len=*), intent(in) :: string + + integer :: idxpos + + if ( idx < 1 .or. idx > list%size ) then + return + endif + + list%string(idx)%value = string +end subroutine replace_string_int_impl + +subroutine replace_string_idx_idx_wrap( list, first, last, string ) + class(stringlist_type), intent(inout) :: list + type(stringlist_index_type), intent(in) :: first + type(stringlist_index_type), intent(in) :: last + character(len=*), intent(in) :: string + + integer :: firstpos, lastpos + + firstpos = merge( first%offset, list%size + first%offset, first%head ) + lastpos = merge( last%offset, list%size + last%offset, last%head ) + + call list%replace( firstpos, lastpos, string ) +end subroutine replace_string_idx_idx_wrap + +subroutine replace_string_int_idx_wrap( list, first, last, string ) + class(stringlist_type), intent(inout) :: list + integer, intent(in) :: first + type(stringlist_index_type), intent(in) :: last + character(len=*), intent(in) :: string + + integer :: lastpos + + lastpos = merge( last%offset, list%size + last%offset, last%head ) + + call list%replace( first, lastpos, string ) +end subroutine replace_string_int_idx_wrap + +subroutine replace_string_idx_int_wrap( list, first, last, string ) + class(stringlist_type), intent(inout) :: list + type(stringlist_index_type), intent(in) :: first + integer, intent(in) :: last + character(len=*), intent(in) :: string + + integer :: firstpos + + firstpos = merge( first%offset, list%size + first%offset, first%head ) + + call list%replace( firstpos, last, string ) +end subroutine replace_string_idx_int_wrap + +subroutine replace_string_int_int_impl( list, first, last, string ) + class(stringlist_type), intent(inout) :: list + integer, intent(in) :: first + integer, intent(in) :: last + character(len=*), intent(in) :: string + + if ( first > list%size .or. last < 1 ) then + return + endif + if ( first > last ) then + return + endif + + call list%delete( first, last ) + call list%insert( first, string ) +end subroutine replace_string_int_int_impl + + +subroutine replace_stringlist_idx_idx_wrap( list, first, last, slist ) + class(stringlist_type), intent(inout) :: list + type(stringlist_index_type), intent(in) :: first + type(stringlist_index_type), intent(in) :: last + class(stringlist_type), intent(in) :: slist + + integer :: firstpos, lastpos + + firstpos = merge( first%offset, list%size + first%offset, first%head ) + lastpos = merge( last%offset, list%size + last%offset, last%head ) + + call list%replace( firstpos, lastpos, slist ) +end subroutine replace_stringlist_idx_idx_wrap + +subroutine replace_stringlist_int_idx_wrap( list, first, last, slist ) + class(stringlist_type), intent(inout) :: list + integer, intent(in) :: first + type(stringlist_index_type), intent(in) :: last + class(stringlist_type), intent(in) :: slist + + integer :: lastpos + + lastpos = merge( last%offset, list%size + last%offset, last%head ) + + call list%replace( first, lastpos, slist ) +end subroutine replace_stringlist_int_idx_wrap + +subroutine replace_stringlist_idx_int_wrap( list, first, last, slist ) + class(stringlist_type), intent(inout) :: list + type(stringlist_index_type), intent(in) :: first + integer, intent(in) :: last + class(stringlist_type), intent(in) :: slist + + integer :: firstpos + + firstpos = merge( first%offset, list%size + first%offset, first%head ) + + call list%replace( firstpos, last, slist ) +end subroutine replace_stringlist_idx_int_wrap + +subroutine replace_stringlist_int_int_impl( list, first, last, slist ) + class(stringlist_type), intent(inout) :: list + integer, intent(in) :: first + integer, intent(in) :: last + class(stringlist_type), intent(in) :: slist + + if ( first > list%size .or. last < 1 ) then + return + endif + if ( first > last ) then + return + endif + + call list%delete( first, last ) + call list%insert( first, slist ) +end subroutine replace_stringlist_int_int_impl + + +subroutine replace_stringarray_idx_idx_wrap( list, first, last, sarray ) + class(stringlist_type), intent(inout) :: list + type(stringlist_index_type), intent(in) :: first + type(stringlist_index_type), intent(in) :: last + character(len=*), dimension(:), intent(in) :: sarray + + integer :: firstpos, lastpos + + firstpos = merge( first%offset, list%size + first%offset, first%head ) + lastpos = merge( last%offset, list%size + last%offset, last%head ) + + call list%replace( firstpos, lastpos, sarray ) +end subroutine replace_stringarray_idx_idx_wrap + +subroutine replace_stringarray_int_idx_wrap( list, first, last, sarray ) + class(stringlist_type), intent(inout) :: list + integer, intent(in) :: first + type(stringlist_index_type), intent(in) :: last + character(len=*), dimension(:), intent(in) :: sarray + + integer :: lastpos + + lastpos = merge( last%offset, list%size + last%offset, last%head ) + + call list%replace( first, lastpos, sarray ) +end subroutine replace_stringarray_int_idx_wrap + +subroutine replace_stringarray_idx_int_wrap( list, first, last, sarray ) + class(stringlist_type), intent(inout) :: list + type(stringlist_index_type), intent(in) :: first + integer, intent(in) :: last + character(len=*), dimension(:), intent(in) :: sarray + + integer :: firstpos + + firstpos = merge( first%offset, list%size + first%offset, first%head ) + + call list%replace( firstpos, last, sarray ) +end subroutine replace_stringarray_idx_int_wrap + +subroutine replace_stringarray_int_int_impl( list, first, last, sarray ) + class(stringlist_type), intent(inout) :: list + integer, intent(in) :: first + integer, intent(in) :: last + character(len=*), dimension(:), intent(in) :: sarray + + if ( first > list%size .or. last < 1 ) then + return + endif + if ( first > last ) then + return + endif + + call list%delete( first, last ) + call list%insert( first, sarray ) +end subroutine replace_stringarray_int_int_impl + +end module stdlib_stringlist diff --git a/src/tests/stringlist/CMakeLists.txt b/src/tests/stringlist/CMakeLists.txt new file mode 100644 index 000000000..7bf83a41a --- /dev/null +++ b/src/tests/stringlist/CMakeLists.txt @@ -0,0 +1,4 @@ +ADDTEST(insert) +ADDTEST(delete) +ADDTEST(find) +ADDTEST(replace_append) diff --git a/src/tests/stringlist/test_delete.f90 b/src/tests/stringlist/test_delete.f90 new file mode 100644 index 000000000..5c3cf0870 --- /dev/null +++ b/src/tests/stringlist/test_delete.f90 @@ -0,0 +1,57 @@ +! test_delete.f90 -- +! Test the delete routine +! +program test_deletion + use stdlib_stringlist + + type(stringlist_type) :: list + + + call list%insert( 1, ["A", "B", "C", "D", "E", "F"] ) + + call list%delete( 1, 1 ) + + write(*,*) 'Expected: B, C, D, E, F (5)' + call print_list( list ) + + call list%delete( list_end, list_end ) + + write(*,*) 'Expected: B, C, D, E (4)' + call print_list( list ) + + call list%delete( list_end+1, list_end+1 ) + + write(*,*) 'Expected: B, C, D, E (4)' + call print_list( list ) + + call list%delete( 3, 2 ) + + write(*,*) 'Expected: B, C, D, E (4)' + call print_list( list ) + + call list%delete( 2, 3 ) + + write(*,*) 'Expected: B, E (2)' + call print_list( list ) + +contains +subroutine renew_list( list ) + type(stringlist_type), intent(inout) :: list + + call list%destroy + call list%insert( 1, "A" ) + call list%insert( 2, "B" ) + call list%insert( 3, "C" ) +end subroutine renew_list + +subroutine print_list( list ) + type(stringlist_type), intent(in) :: list + + write(*,*) list%length() + + do i = 1,list%length() + write(*,*) '>', list%get(i), '<' + enddo +end subroutine print_list + +end program test_deletion diff --git a/src/tests/stringlist/test_find.f90 b/src/tests/stringlist/test_find.f90 new file mode 100644 index 000000000..3db7bd806 --- /dev/null +++ b/src/tests/stringlist/test_find.f90 @@ -0,0 +1,72 @@ +! test_find.f90 -- +! Test the various retrieval routines +! +program test_find + use stdlib_stringlist + + type(stringlist_type) :: list, sublist + character(len=:), allocatable :: string + + call list%insert( 1, ["A", "B", "C", "D", "E", "F"] ) + + write(*,*) 'Expected: A' + write(*,*) list%get(1) + write(*,*) list%get(list_head) + write(*,*) 'Expected: B' + write(*,*) list%get(list_head+1) + write(*,*) 'Expected: F' + write(*,*) list%get(list_end) + write(*,*) 'Expected: (nothing)' + write(*,*) list%get(list_end+1) + + call list%destroy + call list%insert( 1, ["AA", "BA", "CA", "AA", "BA", "CA"] ) + write(*,*) 'Expected: 1' + write(*,*) list%index("AA") + write(*,*) 'Expected: 4' + write(*,*) list%index("AA", .true.) + write(*,*) 'Expected: 0' + write(*,*) list%index("XXXX") + + write(*,*) 'Expected: 2' + write(*,*) list%index_sub("B") + write(*,*) 'Expected: 5' + write(*,*) list%index_sub("B", .true.) + write(*,*) 'Expected: 0' + write(*,*) list%index_sub("X") + + write(*,*) 'Expected: 6', list%length() + + sublist = list%range(1, 2) + write(*,*) 'Expected: AA, BA' + call print_list( sublist ) + + sublist = list%range(list_end-1, list_end+2) + write(*,*) 'Expected: BA, CA' + call print_list( sublist ) + + sublist = list%range(-1, 3) + write(*,*) 'Expected: AA, BA, CA' + call print_list( sublist ) + +contains +subroutine renew_list( list ) + type(stringlist_type), intent(inout) :: list + + call list%destroy + call list%insert( 1, "A" ) + call list%insert( 2, "B" ) + call list%insert( 3, "C" ) +end subroutine renew_list + +subroutine print_list( list ) + type(stringlist_type), intent(in) :: list + + write(*,*) list%length() + + do i = 1,list%length() + write(*,*) '>', list%get(i), '<' + enddo +end subroutine print_list + +end program test_find diff --git a/src/tests/stringlist/test_insert.f90 b/src/tests/stringlist/test_insert.f90 new file mode 100644 index 000000000..6aa6b1198 --- /dev/null +++ b/src/tests/stringlist/test_insert.f90 @@ -0,0 +1,91 @@ +! test_insert.f90 -- +! Test the insertion routine +! +program test_insertion + use stdlib_stringlist + + type(stringlist_type) :: list, second_list + character(len=10), dimension(3) :: sarray + + + call list%insert( 1, "C" ) + call list%insert( 1, "B" ) + call list%insert( 1, "A" ) + + write(*,*) 'Expected: A, B, C (3)' + call print_list( list ) + + call list%insert( 6, "D" ) + + write(*,*) 'Expected: A, B, C, D (4)' + call print_list( list ) + + call list%insert( -1, "X" ) + + write(*,*) 'Expected: X, A, B, C, D (5)' + call print_list( list ) + + call list%insert( list_end-1, "Y" ) + + write(*,*) 'Expected: X, A, B, Y, C, D (6)' + call print_list( list ) + + call list%insert( list_end+1, "Z" ) + + write(*,*) 'Expected: X, A, B, Y, C, D, Z (7)' + call print_list( list ) + + ! + ! Try inserting a second list + ! + call renew_list( list ) + + call second_list%insert( 1, "SecondA" ) + call second_list%insert( 2, "SecondB" ) + + call list%insert( 2, second_list ) + call print_list( list ) + + call renew_list( list ) + + call list%insert( list_after_end, second_list ) + call print_list( list ) + + ! + ! Try inserting an array + ! + call renew_list( list ) + + sarray(1) = "ThirdA" + sarray(2) = "ThirdB" + sarray(3) = "ThirdC" + + call list%insert( list_head, sarray ) + call print_list( list ) + + call renew_list( list ) + + call list%insert( 2, sarray ) + call print_list( list ) + +contains +subroutine renew_list( list ) + type(stringlist_type), intent(inout) :: list + + call list%destroy + call list%insert( 1, "A" ) + call list%insert( 2, "B" ) + call list%insert( 3, "C" ) +end subroutine renew_list + +subroutine print_list( list ) + type(stringlist_type), intent(in) :: list + + write(*,*) list%length() + + do i = 1,list%length() + write(*,*) '>', list%get(i), '<' + enddo +end subroutine print_list + +end program test_insertion diff --git a/src/tests/stringlist/test_replace_append.f90 b/src/tests/stringlist/test_replace_append.f90 new file mode 100644 index 000000000..b7c0c26ed --- /dev/null +++ b/src/tests/stringlist/test_replace_append.f90 @@ -0,0 +1,88 @@ +! test_replace_append.f90 -- +! Test the replace and append routines +! +program test_replace_append + use stdlib_stringlist + + type(stringlist_type) :: list, newlist + + call list%insert( 1, ["A", "B", "C", "D", "E", "F"] ) + + newlist = 'Long string' // list + + write(*,*) 'Expected: "Long string, A, B, C, D, E, F (7)' + call print_list( newlist ) + + newlist = list // 'Long string' + + write(*,*) 'Expected: A, B, C, D, E, F, "Long string" (7)' + call print_list( newlist ) + + newlist = list // list + + write(*,*) 'Expected: A, B, C, D, E, F (twice, 12 elements)' + call print_list( newlist ) + + newlist = ['AA', 'BB'] // list + write(*,*) 'Expected: AA, BB, A, B, C, D, E, F (8)' + call print_list( newlist ) + + newlist = list // ['AA', 'BB'] + write(*,*) 'Expected: A, B, C, D, E, F, AA, BB (8)' + call print_list( newlist ) + + ! + ! Replace ... quite a variety + ! + newlist = list + call newlist%replace( 1, "New string" ) + write(*,*) 'Expected: "New string", B, C, D, E, F (6)' + call print_list( newlist ) + + newlist = list + call newlist%replace( list_head, "New string" ) + write(*,*) 'Expected: "New string", B, C, D, E, F (6)' + call print_list( newlist ) + + newlist = list + call newlist%replace( list_end, "New string" ) + write(*,*) 'Expected: A, B, C, D, E, F, "New string" (6)' + call print_list( newlist ) + + newlist = list + call newlist%replace( 5, list_end, "X" ) + write(*,*) 'Expected: A, B, C, D, X (5)' + call print_list( newlist ) + + newlist = list + call newlist%replace( 5, list_end-2, "X" ) + write(*,*) 'Expected: A, B, C, D, E, F (6 - no change)' + call print_list( newlist ) + + newlist = list + call newlist%replace( 1, 2, ["WW", "XX", "YY", "ZZ"] ) + write(*,*) 'Expected: WW, XX, YY, ZZ, C, D, E, F (8)' + call print_list( newlist ) + + newlist = list + call newlist%replace( list_end-1, list_end, ["WW", "XX", "YY", "ZZ"] ) + write(*,*) 'Expected: A, B, C, D, WW, XX, YY, ZZ (8)' + call print_list( newlist ) + + newlist = list + call newlist%replace( list_end-1, list_end, list ) + write(*,*) 'Expected: A, B, C, D, A, B, C, D, E, F (10)' + call print_list( newlist ) + +contains +subroutine print_list( list ) + type(stringlist_type), intent(in) :: list + + write(*,*) list%length() + + do i = 1,list%length() + write(*,*) '>', list%get(i), '<' + enddo +end subroutine print_list + +end program test_replace_append diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index 7acdfba1c..6fc3305bc 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -23,6 +23,7 @@ add_subdirectory(hash_functions_perf) add_subdirectory(hashmaps) add_subdirectory(io) add_subdirectory(linalg) +add_subdirectory(linked_list) add_subdirectory(logger) add_subdirectory(optval) add_subdirectory(selection) diff --git a/test/linked_list/CMakeLists.txt b/test/linked_list/CMakeLists.txt new file mode 100644 index 000000000..bd1b8094b --- /dev/null +++ b/test/linked_list/CMakeLists.txt @@ -0,0 +1,2 @@ +ADDTEST(performance) +ADDTEST(linked_list) diff --git a/test/linked_list/test_linked_list.f90 b/test/linked_list/test_linked_list.f90 new file mode 100644 index 000000000..a05128f41 --- /dev/null +++ b/test/linked_list/test_linked_list.f90 @@ -0,0 +1,781 @@ +! test_linked_list.f90 -- +! Tests for the linked list module +! +! TODO: +! - absorb +! - splice <-- Crash +! +! Also: attention to large lists with multiple parent nodes +! +! Note: +! Methods set_size, set_number_of_parent_nodes should be private! +! Perhaps even number_of_parent_nodes +! +! Note: +! slice probably does not work correctly with large lists! +! +program test_linked_list + use stdlib_error, only: check + use stdlib_linked_list + + implicit none + + integer :: iunit + + open( newunit = iunit, file = 'test_linked_list.out' ) + write( iunit, '(a)') 'Tests for the linked list module' + write( iunit, '(a)') '' + + call test_size + call test_get + call test_pop + call test_insert + call test_reverse + call test_clear + call test_replace + call test_concat + call test_remove + call test_slice + call test_absorb + call test_splice + + !call test_absorb + + ! + ! Tests with large lists + ! + call test_size_large + + write( iunit, '(a)') '' + write( iunit, '(a)') 'Tests completed' +contains + +! test_size -- +! Check that the size as returned is correct +! +subroutine test_size + type(linked_list_type) :: list + integer :: i + + ! + ! An empty list should return zero + ! + write(iunit, '(/,a)') 'Test: sizes' + write(iunit, '(a,i0)') 'Size of empty list: ', list%size(); flush(iunit) + call check( 0 == list%size(), "Empty list does not return a zero size", warn=.true. ) + + do i = 1,10 + call list%push( i ) + write(iunit, '(a,i0,a,i0)') 'Size of list with ', i, ' elements: ', list%size(); flush(iunit) + call check( i == list%size(), "List does not return the right size", warn=.true. ) + enddo + + call list%clear + write(iunit, '(a,i0)') 'Size of cleared list: ', list%size(); flush(iunit) + call check( 0 == list%size(), "Cleared list does not return a zero size", warn=.true. ) +end subroutine test_size + +! test_get -- +! Check that stored elements are returned correctly via the get function +! +subroutine test_get + type(linked_list_type) :: list + integer :: i + integer :: int_val + real :: real_val + character(len=20) :: string_val + + ! + ! Note: the list does not store arrays, so hide it + ! + type real_array_type + real :: array(20) + end type real_array_type + + type(real_array_type) :: ra + + ! + ! Variable returned can be of any type + ! + class(*), pointer :: data + + write(iunit, '(/,a)') 'Test: get' + ! + ! Store the elements + ! + int_val = 1 + real_val = 2.0 + string_val = "three" + ra%array = [(real(i), i = 1,size(ra%array))] + + call list%push( int_val ) + call list%push( real_val ) + call list%push( string_val ) + call list%push( ra ) + + ! + ! Retrieve them in reverse order (just for fun) + ! + do i = 4,1,-1 + data => list%get(i) + + select type ( d => data ) + type is (integer) + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is integer with value ', d; flush(iunit) + call check( i == 1, "List item 1 not an integer", warn=.true. ) + type is (real) + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is real with value ', d; flush(iunit) + call check( i == 2, "List item 2 not a real", warn=.true. ) + type is (character(*)) + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is string with value ', d; flush(iunit) + call check( i == 3, "List item 3 not a string", warn=.true. ) + type is (real_array_type) + write(iunit, '(a,i0,a,*(g0,1x))') 'Item ', i, ' is derived type containing a real array with values ', d%array + flush(iunit) + call check( i == 4, "List item 4 not a derived type 'real_array'", warn=.true. ) + class default + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is of unknown type'; flush(iunit) + call check( .false., "List item encountered of unknown type", warn=.true. ) + end select + enddo + + ! + ! Change the value of the item - it is a pointer after all. + ! + data => list%get(1) + + select type ( d => data ) + type is (integer) + d = 101 + end select + + data => list%get(1) + + select type ( d => data ) + type is (integer) + write(iunit, '(a,i0,a,g0)') 'Value of item ', i, ' changed to ', d; flush(iunit) + call check( d == 101, "List item 1 does not have the right value (101)", warn=.true. ) + end select + + call list%clear +end subroutine test_get + +! test_pop -- +! Check that stored elements are popped off the list correctly +! +subroutine test_pop + type(linked_list_type) :: list + integer :: i, last + + ! + ! Variable returned can be of any type + ! + class(*), pointer :: data + + write(iunit, '(/,a)') 'Test: pop' + ! + ! Store the elements + ! + do i = 1,10 + call list%push( i ) + enddo + + ! + ! Pop the list (remove the last element) one by one + ! + do i = 10,1,-1 + call list%pop + + last = list%size() + data => list%get(last) + write(iunit, '(a,i0,a,g0)') 'Size after popping item is ', last; flush(iunit) + call check( last == i-1, "List size is not correct after popping an element", warn=.true. ) + + if ( associated(data) ) then + select type ( d => data ) + type is (integer) + write(iunit, '(a,i0,a,g0)') 'Last item ', last, ' is integer with value ', d; flush(iunit) + call check( i-1 == d, "List item does not have the right value", warn=.true. ) + class default + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is of unknown type'; flush(iunit) + call check( .false., "List item encountered of unknown type", warn=.true. ) + end select + else + write(iunit, '(a,i0,a,g0)') 'Empty list - pointer is dissociated'; flush(iunit) + endif + enddo + + call list%clear +end subroutine test_pop + +! test_insert -- +! Check that an element is inserted at the given position (so that the original +! element is shifted down). +! +subroutine test_insert + type(linked_list_type) :: list + integer :: i + integer :: expected(1:2) + + ! + ! Variable returned can be of any type + ! + class(*), pointer :: data + + write(iunit, '(/,a)') 'Test: insert' + ! + ! Store the elements + ! + expected = [500, 5] + + do i = 1,10 + call list%push( i ) + enddo + + ! + ! Insert a new value at the fifth position - the fifth element now comes at position 6. + ! + call list%insert( 500, 5 ) + + write(iunit, '(a,i0,a,g0)') 'Size after inserting a new item is ', list%size(); flush(iunit) + call check( list%size() == 11, "List size is not correct after inserting an element", warn=.true. ) + + + do i = 5,6 + data => list%get( i ) + if ( associated(data) ) then + select type ( d => data ) + type is (integer) + write(iunit, '(a,i0,a,g0)') 'Item at position ', i, ' is integer with value ', d; flush(iunit) + call check( d == expected(i-4), "List item does not have the right value", warn=.true. ) + class default + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is of unknown type'; flush(iunit) + call check( .false., "List item encountered of unknown type", warn=.true. ) + end select + else + write(iunit, '(a,i0,a)') 'No such element ', i, ' - pointer is dissociated'; flush(iunit) + call check( .false., "List item is missing", warn=.true. ) + endif + enddo + + ! + ! Insert at the beginning and after the end + ! + call list%insert( 1000, -1) + call list%insert( 2000, 100) + + expected = [1000, 2000] + + do i = 1,2 + if ( i == 1 ) then + data => list%get( 1 ) + else + data => list%get( list%size() ) + endif + + if ( associated(data) ) then + select type ( d => data ) + type is (integer) + write(iunit, '(a,i0,a,g0)') 'Item at position ', i, ' is integer with value ', d; flush(iunit) + call check( d == expected(i), "List item does not have the right value", warn=.true. ) + class default + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is of unknown type'; flush(iunit) + call check( .false., "List item encountered of unknown type", warn=.true. ) + end select + else + write(iunit, '(a,i0,a)') 'No such element ', i, ' - pointer is dissociated'; flush(iunit) + call check( .false., "List item is missing", warn=.true. ) + endif + enddo + + + call list%clear +end subroutine test_insert + +! test_reverse -- +! Check that a list is properly reversed +! +subroutine test_reverse + type(linked_list_type) :: list + integer :: i + + ! + ! Variable returned can be of any type + ! + class(*), pointer :: data + + write(iunit, '(/,a)') 'Test: reverse' + ! + ! Store the elements + ! + do i = 1,10 + call list%push( i ) + enddo + + ! + ! Reverse the list and check the elements + ! + call list%reverse + + write(iunit, '(a,i0,a,g0)') 'Size after reversing is ', list%size(); flush(iunit) + call check( list%size() == 10, "List size is not correct after reversing", warn=.true. ) + + + do i = 1,list%size() + data => list%get( i ) + if ( associated(data) ) then + select type ( d => data ) + type is (integer) + write(iunit, '(a,i0,a,g0)') 'Item at position ', i, ' is integer with value ', d; flush(iunit) + call check( d == list%size()+1-i, "List item does not have the right value", warn=.true. ) + class default + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is of unknown type'; flush(iunit) + call check( .false., "List item encountered of unknown type", warn=.true. ) + end select + else + write(iunit, '(a,i0,a)') 'No such element ', i, ' - pointer is dissociated'; flush(iunit) + call check( .false., "List item is missing", warn=.true. ) + endif + enddo + + call list%clear +end subroutine test_reverse + +! test_clear -- +! Check that a cleared list does not have any elements +! +subroutine test_clear + type(linked_list_type) :: list + integer :: i + + ! + ! Variable returned can be of any type + ! + class(*), pointer :: data + + write(iunit, '(/,a)') 'Test: clear' + ! + ! Store the elements + ! + do i = 1,10 + call list%push( i ) + enddo + + ! + ! Reverse the list and check the elements + ! + call list%clear + + write(iunit, '(a,i0,a,g0)') 'Size after clearing is ', list%size(); flush(iunit) + call check( list%size() == 0, "List size is not correct after clearing", warn=.true. ) + + data => list%get( 1 ) + + write(iunit, '(2a)') 'Element 1 exists? - pointer is ', merge( 'associated ', 'dissociated', associated(data) ); flush(iunit) + call check( .not. associated(data), "There should be no list item returned", warn=.true. ) + + call list%clear +end subroutine test_clear + +! test_replace -- +! Check that an element is properly replaced +! +subroutine test_replace + type(linked_list_type) :: list + integer :: i + integer :: int_val + character(len=20) :: string_val + + ! + ! Variable returned can be of any type + ! + class(*), pointer :: data + + write(iunit, '(/,a)') 'Test: replace' + ! + ! Store the elements + ! + do i = 1,10 + call list%push( i ) + enddo + + ! + ! Replace element 2 by a string + ! + call list%replace( "TWO", 2 ) + + ! + ! Check the list + ! + write(iunit, '(a,i0,a,g0)') 'Size after replacing is ', list%size(); flush(iunit) + call check( list%size() == 10, "List size is not correct after replacing", warn=.true. ) + + + do i = 1,list%size() + data => list%get(i) + + select type ( d => data ) + type is (integer) + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is integer with value ', d; flush(iunit) + call check( i /= 2, "List item is not an integer", warn=.true. ) + type is (character(*)) + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is string with value ', d; flush(iunit) + call check( i == 2, "List item 2 is not a string", warn=.true. ) + class default + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is of unknown type'; flush(iunit) + call check( .false., "List item encountered of unknown type", warn=.true. ) + end select + enddo + + call list%clear +end subroutine test_replace + + +! +! Tests for large lists +! + +! test_size_large -- +! Check that the size of large lists as returned is correct +! +subroutine test_size_large + type(linked_list_type) :: list + integer :: i + + write(iunit, '(/,a)') 'Test: size of large lists' + + do i = 1,100000 + call list%push( i ) + + if ( mod(i,5001) == 1 ) then + write(iunit, '(a,i0,a,i0)') 'Size of list with ', i, ' elements: ', list%size(); flush(iunit) + write(iunit, '(a,i0,a,i0)') 'Number of parent nodes: ', list%number_of_parent_nodes(); flush(iunit) + call check( i == list%size(), "List does not return the right size", warn=.true. ) + endif + enddo + + call list%clear +end subroutine test_size_large + +! test_concat -- +! Check that a list is correctly concatenated to the end of the original list +! +subroutine test_concat + type(linked_list_type) :: list, sublist + integer :: i + character(len=20) :: string_val + + ! + ! Variable returned can be of any type + ! + class(*), pointer :: data + + write(iunit, '(/,a)') 'Test: concat' + ! + ! Store the elements + ! + do i = 1,10 + call list%push( i ) + enddo + + call sublist%push( 'ONE' ) + call sublist%push( 'TWO' ) + call sublist%push( 'THREE' ) + call sublist%push( 'FOUR' ) + + ! + ! Concatenate the sublist + ! + call list%concat( sublist ) + + write(iunit, '(a,i0,a,i0)') 'Size of concatenated list is: ', list%size(); flush(iunit) + call check( list%size() == 14, "Concatenated list does not return the right size", warn=.true. ) + + ! + ! Check the contents + ! + do i = 1,list%size() + data => list%get(i) + + select type ( d => data ) + type is (integer) + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is integer with value ', d; flush(iunit) + call check( i <= 10, "Item in concatenated list is not an integer", warn=.true. ) + type is (character(*)) + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is string with value ', d + call check( i > 10, "item in concatenated list is not a string", warn=.true. ) + class default + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is of unknown type'; flush(iunit) + call check( .false., "List item encountered of unknown type", warn=.true. ) + end select + enddo + + call list%clear +end subroutine test_concat + +! test_absorb -- +! Check that an abosrbed list is correctly moved to the absorbing list +! +subroutine test_absorb + type(linked_list_type) :: list, sublist + integer :: i + character(len=20) :: string_val + + ! + ! Variable returned can be of any type + ! + class(*), pointer :: data + + write(iunit, '(/,a)') 'Test: absorb' + ! + ! Store the elements + ! + do i = 1,10 + call list%push( i ) + enddo + + call sublist%push( 'ONE' ) + call sublist%push( 'TWO' ) + call sublist%push( 'THREE' ) + call sublist%push( 'FOUR' ) + + ! + ! Concatenate the sublist and + ! check that the absorbed list is now empty + ! + call list%absorb( sublist ) + + write(iunit, '(a,i0,a,i0)') 'Size of absorbing list is: ', list%size(); flush(iunit) + call check( list%size() == 14, "Absorbing list does not return the right size", warn=.true. ) + + write(iunit, '(a,i0,a,i0)') 'Size of absorbed list is: ', sublist%size(); flush(iunit) + call check( sublist%size() == 0, "Absorbed list does not return the right size", warn=.true. ) + + ! + ! Check the contents of the absorbing list + ! + do i = 1,list%size() + data => list%get(i) + + select type ( d => data ) + type is (integer) + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is integer with value ', d; flush(iunit) + call check( i <= 10, "Item in concatenated list is not an integer", warn=.true. ) + type is (character(*)) + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is string with value ', d; flush(iunit) + call check( i > 10, "item in concatenated list is not a string", warn=.true. ) + class default + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is of unknown type'; flush(iunit) + call check( .false., "List item encountered of unknown type", warn=.true. ) + end select + enddo + + + call list%clear +end subroutine test_absorb + +! test_remove -- +! Check that a list element is properly removed +! +subroutine test_remove + type(linked_list_type) :: list + integer :: i + + ! + ! Variable returned can be of any type + ! + class(*), pointer :: data + + write(iunit, '(/,a)') 'Test: remove' + ! + ! Store the elements + ! + do i = 1,10 + call list%push( i ) + enddo + + ! + ! Remove the first and the last elements + ! + call list%remove( 10 ) + call list%remove( 1 ) + + write(iunit, '(a,i0,a,i0)') 'Size of list with two removed is: ', list%size(); flush(iunit) + call check( list%size() == 8, "List with removed elements does not return the right size", warn=.true. ) + + ! + ! Check the contents + ! + do i = 1,list%size() + data => list%get(i) + + select type ( d => data ) + type is (integer) + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is integer with value ', d; flush(iunit) + call check( d > 1 .and. d < 10, "Item in list is out of range", warn=.true. ) + class default + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is of unknown type'; flush(iunit) + call check( .false., "List item encountered of unknown type", warn=.true. ) + end select + enddo + + call list%clear +end subroutine test_remove + +! test_slice -- +! Check that the proper slice of a list is returned +! +subroutine test_slice + type(linked_list_type) :: list, slice + integer :: i + + ! + ! Variable returned can be of any type + ! + class(*), pointer :: data + + write(iunit, '(/,a)') 'Test: slice' + ! + ! Store the elements + ! + do i = 1,10 + call list%push( i ) + enddo + + ! + ! Get a slice of the list + ! + slice = list%slice( 2, 4 ) + + write(iunit, '(a,i0,a,i0)') 'Size of slice is: ', slice%size(); flush(iunit) + call check( slice%size() == 3, "Slice does not return the right size", warn=.true. ) + + write(iunit, '(a,i0,a,i0)') 'Size of original list is: ', list%size(); flush(iunit) + call check( list%size() == 10, "Original list does not return the right size", warn=.true. ) + + ! + ! Check the contents + ! + do i = 1,slice%size() + data => slice%get(i) + + select type ( d => data ) + type is (integer) + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is integer with value ', d; flush(iunit) + call check( d >= 2 .and. d <= 4, "Item in list is out of range", warn=.true. ) + class default + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is of unknown type'; flush(iunit) + call check( .false., "List item encountered of unknown type", warn=.true. ) + end select + enddo + + call list%clear + call slice%clear +end subroutine test_slice + +! test_splice -- +! Check that a list is properly spliced (a piece is removed) +! +subroutine test_splice + type(linked_list_type) :: list + integer :: i + + ! + ! Variable returned can be of any type + ! + class(*), pointer :: data + + write(iunit, '(/,a)') 'Test: splice' + ! + ! Store the elements + ! + do i = 1,10 + call list%push( i ) + enddo + + ! + ! Remove the middle part of the list + ! + call list%splice( 2, 9 ) + + write(iunit, '(a,i0,a,i0)') 'Size of spliced list is: ', list%size(); flush(iunit) + call check( list%size() == 2, "Spliced list does not return the right size", warn=.true. ) + + ! + ! Check the contents + ! + do i = 1,list%size() + data => list%get(i) + + select type ( d => data ) + type is (integer) + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is integer with value ', d; flush(iunit) + call check( d == 1 .or. d == 10, "Item in list is out of range", warn=.true. ) + class default + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is of unknown type'; flush(iunit) + call check( .false., "List item encountered of unknown type", warn=.true. ) + end select + enddo + + call list%clear + + ! Further tests: remove first half, remove last half + ! + ! Store the elements + ! + do i = 1,10 + call list%push( i ) + enddo + + ! + ! Remove the first half + ! + call list%splice( -1, 5 ) !<== Removing the first element gives trouble! + + write(iunit, '(a,i0,a,i0)') 'Size of spliced list (first half removed) is: ', list%size(); flush(iunit) + call check( list%size() == 5, "Spliced list (first half removed) does not return the right size", warn=.true. ) + + ! + ! Check the contents + ! + do i = 1,list%size() + data => list%get(i) + + select type ( d => data ) + type is (integer) + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is integer with value ', d; flush(iunit) + call check( d > 5, "Item in list is out of range", warn=.true. ) + class default + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is of unknown type'; flush(iunit) + call check( .false., "List item encountered of unknown type", warn=.true. ) + end select + enddo + + ! + ! Remove the second half + ! + call list%splice( 3, 10 ) + + write(iunit, '(a,i0,a,i0)') 'Size of spliced list (second half removed) is: ', list%size(); flush(iunit) + call check( list%size() == 2, "Spliced list (second half removed) does not return the right size", warn=.true. ) + + ! + ! Check the contents + ! + do i = 1,list%size() + data => list%get(i) + + select type ( d => data ) + type is (integer) + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is integer with value ', d; flush(iunit) + call check( d >= 6 .and. d <= 7, "Item in list is out of range", warn=.true. ) + class default + write(iunit, '(a,i0,a,g0)') 'Item ', i, ' is of unknown type'; flush(iunit) + call check( .false., "List item encountered of unknown type", warn=.true. ) + end select + enddo + + call list%clear +end subroutine test_splice + +end program test_linked_list diff --git a/test/linked_list/test_performance.f90 b/test/linked_list/test_performance.f90 new file mode 100644 index 000000000..6aa7a3aaf --- /dev/null +++ b/test/linked_list/test_performance.f90 @@ -0,0 +1,72 @@ +program test_link + use stdlib_linked_list + implicit none + + type struct + integer:: a=1,b=2,c=3 + double precision::d=5 + end type struct + type(struct) :: Vel2 + + type vector + double precision, dimension(3):: vec + end type vector + type(vector) ::Vel + + type(linked_list_type) :: L + integer :: i,j,length + real :: T1,T2,F, r + integer :: cnt1, cnt2, count_rate + + class(*), pointer :: data + + do i=1,size(Vel%vec) + Vel%vec(i) = i + end do + ! !------------- + ! !Append items + ! !------------- + print*, "Length Of Required List" + !read(*,*) length + length = 1000000 + + call system_clock( cnt1, count_rate = count_rate ) + call cpu_time(T1) + do i=1,length + call L%push(i) + end do + call cpu_time(T2) + call system_clock( cnt2, count_rate = count_rate ) + i = 1 + + write(*,*) T2-T1, (cnt2 - cnt1)/real(count_rate) + + call system_clock( cnt1, count_rate = count_rate ) + call cpu_time(T1) + do while (i<=100) + call random_number( r ) + j = r*length + data => L%get(j) + select type (data) + type is (integer) + end select + i = i+1 + end do + call cpu_time(T2) + call system_clock( cnt2, count_rate = count_rate ) + + write(*,*) (T2-T1), (cnt2 - cnt1)/real(count_rate) + write(*,*)'Done' + + !------------- + !Destroy the list and frees the memmory + !------------- + call system_clock( cnt1, count_rate = count_rate ) + call cpu_time(T1) + call L%clear() + call cpu_time(T2) + call system_clock( cnt2, count_rate = count_rate ) + + write(*,*) T2-T1, (cnt2 - cnt1)/real(count_rate) + +end program test_link