AVL tree: Difference between revisions
Content added Content deleted
Line 2,822: | Line 2,822: | ||
{{works with|Fortran|2008}} |
{{works with|Fortran|2008}} |
||
{{works with|Fortran|2018}} |
{{works with|Fortran|2018}} |
||
The following AVL tree implementation is for keys and data of any type, |
The following AVL tree implementation is for keys and data of any type, mixed freely. This is made possible by Fortran 2008’s unlimited polymorphism. The demonstration is for '''INTEGER''' keys and mixtures of '''REAL''' and '''CHARACTER''' data. |
||
<lang fortran>module avl_trees |
<lang fortran>module avl_trees |
||
Line 3,511: | Line 3,511: | ||
! *exactly*. |
! *exactly*. |
||
if (0 < abs (real_cast (retval) - real (the_keys(j)))) error stop |
if (0 < abs (real_cast (retval) - real (the_keys(j)))) error stop |
||
end if |
|||
if (found) then |
|||
block |
|||
character(len = 1), parameter :: ch = '*' |
|||
! |
|||
! Try replacing the data with a character and then |
|||
! restoring the number. |
|||
! |
|||
call avl_insert (lt, the_keys(j), ch, tree) |
|||
call avl_retrieve (lt, the_keys(j), tree, found, retval) |
|||
if (.not. found) error stop |
|||
if (char_cast (retval) /= ch) error stop |
|||
call avl_insert (lt, the_keys(j), real (the_keys(j)), tree) |
|||
call avl_retrieve (lt, the_keys(j), tree, found, retval) |
|||
if (.not. found) error stop |
|||
if (0 < abs (real_cast (retval) - real (the_keys(j)))) error stop |
|||
end block |
|||
end if |
end if |
||
end do |
end do |
||
Line 3,523: | Line 3,540: | ||
call fisher_yates_shuffle (the_keys, keys_count) |
call fisher_yates_shuffle (the_keys, keys_count) |
||
do i = 1, keys_count |
do i = 1, keys_count |
||
call avl_delete (lt, the_keys(i), tree) |
|||
call avl_check (tree) |
|||
if (avl_size (tree) /= keys_count - i) error stop |
|||
! Try deleting a second time. |
|||
call avl_delete (lt, the_keys(i), tree) |
call avl_delete (lt, the_keys(i), tree) |
||
call avl_check (tree) |
call avl_check (tree) |
||
Line 3,582: | Line 3,603: | ||
end select |
end select |
||
end function real_cast |
end function real_cast |
||
function char_cast (u) result (v) |
|||
class(*), intent(in) :: u |
|||
character(len = 1) :: v |
|||
select type (u) |
|||
type is (character(*)) |
|||
v = u |
|||
class default |
|||
! This case is not handled. |
|||
error stop |
|||
end select |
|||
end function char_cast |
|||
function lt (u, v) result (u_lt_v) |
function lt (u, v) result (u_lt_v) |