1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197
| module ObserverInterfaces implicit none private
type, abstract, public :: IObserver contains procedure(IUpdate), deferred :: update end type IObserver
abstract interface subroutine IUpdate(this, state) import IObserver class(IObserver), intent(inout) :: this integer, intent(in) :: state end subroutine IUpdate end interface
type, abstract, public :: ISubject contains procedure(IAttach), deferred :: attach procedure(IDetach), deferred :: detach procedure(INotify), deferred :: notify end type ISubject
abstract interface subroutine IAttach(this, observer) import ISubject import IObserver class(ISubject), intent(inout) :: this integer, intent(in) :: observer end subroutine IAttach
subroutine IDetach(this, observer) import ISubject import IObserver class(ISubject), intent(inout) :: this integer, intent(in) :: observer end subroutine IDetach
subroutine INotify(this) import ISubject class(ISubject), intent(inout) :: this end subroutine INotify end interface
end module ObserverInterfaces
module ConcreteSubject use ObserverInterfaces implicit none private
type, extends(ISubject), public :: ConcreteSubjectType private integer :: state_ = 0 integer, allocatable :: observers(:) contains procedure :: attach => AttachObserver procedure :: detach => DetachObserver procedure :: notify => NotifyObservers procedure :: setState => SetState procedure :: getState => GetState end type ConcreteSubjectType
contains
subroutine AttachObserver(this, observer) class(ConcreteSubjectType), intent(inout) :: this integer, intent(in) :: observer integer, allocatable :: new_observers(:)
if (.not. allocated(this%observers)) then allocate(this%observers(1)) this%observers(1) = observer return end if allocate(new_observers(size(this%observers) + 1)) new_observers(1:size(this%observers)) = this%observers new_observers(size(this%observers) + 1) = observer deallocate(this%observers) this%observers = new_observers deallocate(new_observers) end subroutine AttachObserver
subroutine DetachObserver(this, observer) class(ConcreteSubjectType), intent(inout) :: this integer, intent(in) :: observer integer :: i, obs_size logical :: found integer, allocatable :: new_observers(:)
obs_size = size(this%observers) allocate(new_observers(obs_size - 1)) found = .false. do i = 1, obs_size if (this%observers(i) == observer) then found = .true. else if (i < obs_size) then new_observers(i) = this%observers(i) else new_observers(i-1) = this%observers(i) end if end if end do if (found) then this%observers = new_observers deallocate(new_observers) end if end subroutine DetachObserver
subroutine NotifyObservers(this) class(ConcreteSubjectType), intent(inout) :: this integer :: i
do i = 1, size(this%observers) write(*,*) "Notifying Observer ", this%observers(i), " with state: ", this%state_ end do end subroutine NotifyObservers
subroutine SetState(this, state) class(ConcreteSubjectType), intent(inout) :: this integer, intent(in) :: state this%state_ = state call this%notify() end subroutine SetState
function GetState(this) result(state) class(ConcreteSubjectType), intent(in) :: this integer :: state state = this%state_ end function GetState
end module ConcreteSubject
module ConcreteObservers use ObserverInterfaces implicit none private
type, extends(IObserver), public :: ConcreteObserverType private integer, public :: name = 0 integer :: state_ = -1 integer :: subject_id_ = -1 contains procedure :: update => UpdateState end type ConcreteObserverType
contains
subroutine UpdateState(this, state) class(ConcreteObserverType), intent(inout) :: this integer, intent(in) :: state this%state_ = state write(*,*) "Observer ", this%name, " received state: ", this%state_ end subroutine UpdateState
end module ConcreteObservers
program ObserverPattern use ObserverInterfaces use ConcreteSubject use ConcreteObservers implicit none
type(ConcreteSubjectType) :: subject type(ConcreteObserverType), pointer :: observer1, observer2, observer3
allocate(observer1) observer1%name = 1
allocate(observer2) observer2%name = 2
allocate(observer3) observer3%name = 3
call subject%attach(observer1%name) call subject%attach(observer2%name) call subject%attach(observer3%name)
write(*,*) "Changing subject state to 20..." call subject%setState(20)
write(*,*) "" write(*,*) "Removing observer 2..." call subject%detach(observer2%name)
write(*,*) "Changing subject state to 30..." call subject%setState(30)
deallocate(observer1, observer2, observer3)
end program ObserverPattern
|