Skip to content

Commit

Permalink
some updates and a new example
Browse files Browse the repository at this point in the history
  • Loading branch information
jacobwilliams committed Dec 29, 2023
1 parent b8952d4 commit acaa8e5
Show file tree
Hide file tree
Showing 2 changed files with 126 additions and 24 deletions.
54 changes: 30 additions & 24 deletions src/dag_module.f90
Original file line number Diff line number Diff line change
Expand Up @@ -16,6 +16,9 @@ module dag_module
character(len=:),allocatable :: label !! used for diagraph
character(len=:),allocatable :: attributes !! used for diagraph
end type edge
interface edge
procedure :: edge_constructor
end interface edge

type :: vertex
!! a vertex of a directed acyclic graph (DAG)
Expand Down Expand Up @@ -63,6 +66,23 @@ module dag_module
contains
!*******************************************************************************

!*******************************************************************************
!>
! Constructor for [[edge]] type.

pure elemental function edge_constructor(ivertex,label,attributes) result(e)

integer,intent(in),optional :: ivertex
character(len=*),intent(in),optional :: label
character(len=*),intent(in),optional :: attributes
type(edge) :: e
e%ivertex = ivertex
if (present(label)) e%label = label
if (present(attributes)) e%attributes = attributes

end function edge_constructor
!*******************************************************************************

!*******************************************************************************
!>
! Destroy the `dag`.
Expand Down Expand Up @@ -120,31 +140,11 @@ subroutine add_edge(me,e,label,attributes)

if (allocated(me%edges)) then
if (.not. any(e==me%edges%ivertex)) then ! don't add if already there

! me%edges = [me%edges, edge(e,label=label,attributes=attributes)]
if (present(label) .and. present(attributes)) then
me%edges = [me%edges, edge(e,label=label,attributes=attributes)]
else if (.not. present(label) .and. present(attributes)) then
me%edges = [me%edges, edge(e,attributes=attributes)]
else if (present(label) .and. .not. present(attributes)) then
me%edges = [me%edges, edge(e,label=label)]
else
me%edges = [me%edges, edge(e)]
end if
me%edges = [me%edges, edge(e,label=label,attributes=attributes)]
call sort_ascending(me%edges)
end if
else
allocate(me%edges(1))
! me%edges = [edge(e,label=label,attributes=attributes)]
if (present(label) .and. present(attributes)) then
me%edges = [edge(e,label=label,attributes=attributes)]
else if (.not. present(label) .and. present(attributes)) then
me%edges = [edge(e,attributes=attributes)]
else if (present(label) .and. .not. present(attributes)) then
me%edges = [edge(e,label=label)]
else
me%edges = [edge(e)]
end if
me%edges = [edge(e,label=label,attributes=attributes)]
end if

end subroutine add_edge
Expand Down Expand Up @@ -216,6 +216,8 @@ subroutine dag_set_vertices(me,nvertices,labels)
character(len=*),dimension(nvertices),intent(in),optional :: labels !! vertex name strings
integer :: i !! counter

if (nvertices<=0) error stop 'error: nvertices must be >= 1'

if (allocated(me%vertices)) deallocate(me%vertices)

me%n = nvertices
Expand Down Expand Up @@ -444,8 +446,10 @@ function dag_generate_digraph(me,rankdir,dpi) result(str)

! define the vertices:
do i=1,me%n
has_label = allocated(me%vertices(i)%label)
has_label = allocated(me%vertices(i)%label)
if (has_label) has_label = me%vertices(i)%label /= ''
has_attributes = allocated(me%vertices(i)%attributes)
if (has_attributes) has_attributes = me%vertices(i)%attributes /= ''
if (has_label) label = 'label="'//trim(adjustl(me%vertices(i)%label))//'"'
if (has_label .and. has_attributes) then
attributes = '['//trim(adjustl(me%vertices(i)%attributes))//','//label//']'
Expand Down Expand Up @@ -479,8 +483,10 @@ function dag_generate_digraph(me,rankdir,dpi) result(str)
if (.not. compress) then
! Example: 1 -> 2 [penwidth=2, arrowhead=none]
do j=1,n_edges
has_label = allocated(me%vertices(i)%edges(j)%label)
has_label = allocated(me%vertices(i)%edges(j)%label)
if (has_label) has_label = me%vertices(i)%edges(j)%label /= ''
has_attributes = allocated(me%vertices(i)%edges(j)%attributes)
if (has_attributes) has_attributes = me%vertices(i)%edges(j)%attributes /= ''
if (has_label) label = 'label="'//trim(adjustl(me%vertices(i)%edges(j)%label))//'"'
if (has_label .and. has_attributes) then
attributes = '['//trim(adjustl(me%vertices(i)%edges(j)%attributes))//','//label//']'
Expand Down
96 changes: 96 additions & 0 deletions test/dag_example_3.f90
Original file line number Diff line number Diff line change
@@ -0,0 +1,96 @@
!*******************************************************************************
!>
! DAG module test program: Advent of Code 2023 Day 25 (test problem).

program dag_example_3

use dag_module

implicit none

type(dag) :: d
integer :: i, n_nodes
character(len=3),dimension(:),allocatable :: labels

character(len=*),parameter :: filetype = 'pdf' !! filetype for output plot ('pdf', png', etc.)

n_nodes = 0
!allocate(labels(0))
do i = 1, 2
! first pass just gets the nodes, 2nd gets the dependencies
call process(i, 'jqt', ['rhn', 'xhk', 'nvd'])
call process(i, 'rsh', ['frs', 'pzl', 'lsr'])
call process(i, 'xhk', ['hfx'])
call process(i, 'cmg', ['qnr', 'nvd', 'lhk', 'bvb'])
call process(i, 'rhn', ['xhk', 'bvb', 'hfx'])
call process(i, 'bvb', ['xhk', 'hfx'])
call process(i, 'pzl', ['lsr', 'hfx', 'nvd'])
call process(i, 'qnr', ['nvd'])
call process(i, 'ntq', ['jqt', 'hfx', 'bvb', 'xhk'])
call process(i, 'nvd', ['lhk'])
call process(i, 'lsr', ['lhk'])
call process(i, 'rzs', ['qnr', 'cmg', 'lsr', 'rsh'])
call process(i, 'frs', ['qnr', 'lhk', 'lsr'])
call process(i, 'hfx')
call process(i, 'lhk')
if (i==1) then
write(*,*) 'set_vertices !'
call d%set_vertices(n_nodes, labels=labels)
end if
end do

call d%save_digraph('test3.dot','RL',300)
call execute_command_line('cat test3.dot')
call execute_command_line('dot -T'//filetype//' -o test3.'//filetype//' test3.dot')

contains
subroutine process(icase, node, dependson)
integer,intent(in) :: icase
character(len=3),intent(in) :: node
character(len=3),dimension(:),intent(in),optional :: dependson
character(len=100),dimension(:),allocatable :: edge_attributes
integer :: i !! counter
integer,dimension(1) :: idx
character(len=*),parameter :: DEFAULT_EDGE = 'arrowhead=none'
character(len=*),parameter :: EDGES_TO_CUT = 'arrowhead=none,color=red'

if (icase==1) then
n_nodes = n_nodes + 1
if (allocated(labels)) then
labels = [labels, node]
else
labels = [node]
end if
else
if (present(dependson)) then
allocate(edge_attributes(size(dependson)))
edge_attributes = DEFAULT_EDGE
if (node=='pzl' .and. any(findloc(labels,'hfx')>0)) then
idx = findloc(dependson,'hfx'); i = idx(1)
edge_attributes(i) = EDGES_TO_CUT
call d%set_edges(node_index(node), node_index(dependson), attributes = edge_attributes)
else if (node=='cmg' .and. any(findloc(labels,'bvb')>0)) then
idx = findloc(dependson,'bvb'); i = idx(1)
edge_attributes(i) = EDGES_TO_CUT
call d%set_edges(node_index(node), node_index(dependson), attributes = edge_attributes)
else if (node=='jqt' .and. any(findloc(labels,'nvd')>0)) then
idx = findloc(dependson,'nvd'); i = idx(1)
edge_attributes(i) = EDGES_TO_CUT
call d%set_edges(node_index(node), node_index(dependson), attributes = edge_attributes)
else
call d%set_edges(node_index(node), node_index(dependson))
end if
end if
end if
end subroutine process

pure elemental integer function node_index(node)
!! find the node number for this name
character(len=3),intent(in) :: node
integer,dimension(1) :: idx
idx = findloc(labels,node)
node_index = idx(1)
end function node_index

end program dag_example_3
!*******************************************************************************

0 comments on commit acaa8e5

Please sign in to comment.