Fortran的23种设计模式
《Fortran的23种设计模式》是一份Fortran面向对象编程中文实用教程。
| 项目 | 描述 |
|---|---|
| 版本： | 0.3.0 |
| 作者： | ZUO Zhihua |
| 网页： | https://zoziha.github.io/Fortran-Design-Patterns/ |
| 版权： | Copyright (c) 2021~2024 zoziha |
开始
软件依赖
获取代码
git clone https://github.com/zoziha/Fortran-Design-Patterns.git
cd Fortran-Design-Patterns
使用fortran-lang/fpm构建代码
Fortran包管理器（fpm）是Fortran-lang社区驱动、为Fortran生态设计的包管理器和代码构建器。
你可以通过提供的fpm.toml构建代码：
fpm test --list # 获取已提供的设计模式示例
fpm test <pattern_name, see `fpm.toml` or test list>
使用mdbook构建文档
mdBook是一个从Markdown文件创建现代在线书籍的实用程序。
你可以通过提供的book.toml文件来构建《Fortran的23种设计模式》。
cd doc && mdbook build
链接
开源许可证
BSD 3-Clause License
Copyright (c) 2021~2024, ZUO Zhihua All rights reserved.
Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
-
Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
-
Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
-
Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Fortran的23种设计模式
视频链接：https://www.bilibili.com/video/BV1wU4y1E7xG?spm_id_from=333.999.0.0
设计模式：https://refactoringguru.cn/design-patterns/go
Fortran三种编程范式：https://zhuanlan.zhihu.com/p/412243161
在线编译器：https://godbolt.org/
面向对象：面向对象的内核是传递信息，以对象（结构体）为载体，它是建模直观的。
设计模式：模式的概念是由克里斯托佛·亚历山大在其著作《建筑模式语言》中首次提出的。模式可复用，除非有必要，不必重新思考模式。
设计模式列表
| 状态 | 创建型模式 | 结构型模式 | 行为模式 |
|---|---|---|---|
| 完成 | 抽象工厂、生成器、工厂方法、原型、单例。 | 适配器、桥接、组合、装饰、外观、代理、享元。 | 责任链、命令、迭代器、观察者、状态、模板方法、备忘录、中介者、访问者、策略。 |
创建型模式
- 抽象工厂
- 生成器
- 工厂方法
- 原型
- 单例
结构型模式
- 适配器
- 桥接
- 组合
- 装饰
- 外观
- 享元
- 代理
行为模式
- 责任链
- 命令
- 迭代器
- 中介者
- 备忘录
- 观察者
- 状态
- 策略
- 模板方法
- 访问者
抽象工厂模式
正文：https://refactoringguru.cn/design-patterns/abstract-factory
Go代码：https://refactoringguru.cn/design-patterns/abstract-factory/go/example
点评：显然易见，抽象工厂设计模式缺点之一是，向应用中引入众多的接口和类，代码可能会因此变得更加复杂。
module abstract_factory_module
use, intrinsic :: iso_fortran_env, only: int8
implicit none
private
public :: isports_factory_type, erke_type, lining_type, get_sports_factory, erke_shoe_type, &
erke_shirt_type, lining_shoe_type, lining_shirt_type, ishoe_type, ishirt_type
!> Abstract classes
type, abstract :: isports_factory_type
contains
procedure(isports_factory_type_make_shoe), deferred :: make_shoe
procedure(isports_factory_type_make_shirt), deferred :: make_shirt
end type isports_factory_type
type, abstract :: ishoe_type
contains
procedure(ishoe_type_set_logo), deferred :: set_logo
procedure(ishoe_type_set_size), deferred :: set_size
procedure(ishoe_type_get_logo), deferred :: get_logo
procedure(ishoe_type_get_size), deferred :: get_size
end type ishoe_type
type, abstract :: ishirt_type
contains
procedure(ishirt_type_set_logo), deferred :: set_logo
procedure(ishirt_type_set_size), deferred :: set_size
procedure(ishirt_type_get_logo), deferred :: get_logo
procedure(ishirt_type_get_size), deferred :: get_size
end type ishirt_type
abstract interface
function isports_factory_type_make_shoe(self) result(shoe)
import isports_factory_type, ishoe_type
class(isports_factory_type), intent(inout) :: self
class(ishoe_type), allocatable :: shoe
end function isports_factory_type_make_shoe
function isports_factory_type_make_shirt(self) result(shirt)
import isports_factory_type, ishirt_type
class(isports_factory_type), intent(inout) :: self
class(ishirt_type), allocatable :: shirt
end function isports_factory_type_make_shirt
subroutine ishoe_type_set_logo(self, logo)
import ishoe_type
class(ishoe_type), intent(inout) :: self
character(*), intent(in) :: logo
end subroutine ishoe_type_set_logo
subroutine ishoe_type_set_size(self, size)
import ishoe_type, int8
class(ishoe_type), intent(inout) :: self
integer(int8), intent(in) :: size
end subroutine ishoe_type_set_size
function ishoe_type_get_logo(self) result(logo)
import ishoe_type
class(ishoe_type), intent(inout) :: self
character(:), allocatable :: logo
end function ishoe_type_get_logo
function ishoe_type_get_size(self) result(size)
import ishoe_type, int8
class(ishoe_type), intent(inout) :: self
integer(int8) :: size
end function ishoe_type_get_size
subroutine ishirt_type_set_logo(self, logo)
import ishirt_type
class(ishirt_type), intent(inout) :: self
character(*), intent(in) :: logo
end subroutine ishirt_type_set_logo
subroutine ishirt_type_set_size(self, size)
import ishirt_type, int8
class(ishirt_type), intent(inout) :: self
integer(int8), intent(in) :: size
end subroutine ishirt_type_set_size
function ishirt_type_get_logo(self) result(logo)
import ishirt_type
class(ishirt_type), intent(inout) :: self
character(:), allocatable :: logo
end function ishirt_type_get_logo
function ishirt_type_get_size(self) result(size)
import ishirt_type, int8
class(ishirt_type), intent(inout) :: self
integer(int8) :: size
end function ishirt_type_get_size
end interface
!> Specific objects
type, extends(isports_factory_type) :: erke_type
contains
procedure :: make_shoe => erke_type_make_shoe
procedure :: make_shirt => erke_type_make_shirt
end type erke_type
type, extends(isports_factory_type) :: lining_type
contains
procedure :: make_shoe => lining_type_make_shoe
procedure :: make_shirt => lining_type_make_shirt
end type lining_type
type, extends(ishoe_type) :: shoe_type
character(:), allocatable :: logo
integer(int8) :: size
contains
procedure :: set_logo => shoe_type_set_logo
procedure :: set_size => shoe_type_set_size
procedure :: get_logo => shoe_type_get_logo
procedure :: get_size => shoe_type_get_size
end type shoe_type
type, extends(ishirt_type) :: shirt_type
character(:), allocatable :: logo
integer(int8) :: size
contains
procedure :: set_logo => shirt_type_set_logo
procedure :: set_size => shirt_type_set_size
procedure :: get_logo => shirt_type_get_logo
procedure :: get_size => shirt_type_get_size
end type shirt_type
type, extends(shoe_type) :: erke_shoe_type
end type erke_shoe_type
type, extends(shoe_type) :: lining_shoe_type
end type lining_shoe_type
type, extends(shirt_type) :: erke_shirt_type
end type erke_shirt_type
type, extends(shirt_type) :: lining_shirt_type
end type lining_shirt_type
contains
function get_sports_factory(brand) result(isports_factory)
character(*), intent(in) :: brand
class(isports_factory_type), allocatable :: isports_factory
select case (brand)
case ("erke")
isports_factory = erke_type()
case ("lining")
isports_factory = lining_type()
case default
error stop "*<ERROR>* Brand not supported."
end select
end function get_sports_factory
function erke_type_make_shoe(self) result(shoe)
class(erke_type), intent(inout) :: self
class(ishoe_type), allocatable :: shoe
shoe = erke_shoe_type(logo="erke", size=15_int8)
end function erke_type_make_shoe
function erke_type_make_shirt(self) result(shirt)
class(erke_type), intent(inout) :: self
class(ishirt_type), allocatable :: shirt
shirt = erke_shirt_type(logo="erke", size=84_int8)
end function erke_type_make_shirt
function lining_type_make_shoe(self) result(shoe)
class(lining_type), intent(inout) :: self
class(ishoe_type), allocatable :: shoe
shoe = lining_shoe_type(logo="lining", size=14_int8)
end function lining_type_make_shoe
function lining_type_make_shirt(self) result(shirt)
class(lining_type), intent(inout) :: self
class(ishirt_type), allocatable :: shirt
shirt = lining_shirt_type(logo="lining", size=85_int8)
end function lining_type_make_shirt
subroutine shoe_type_set_logo(self, logo)
class(shoe_type), intent(inout) :: self
character(*), intent(in) :: logo
self%logo = logo
end subroutine shoe_type_set_logo
subroutine shoe_type_set_size(self, size)
class(shoe_type), intent(inout) :: self
integer(int8), intent(in) :: size
self%size = size
end subroutine shoe_type_set_size
function shoe_type_get_logo(self) result(logo)
class(shoe_type), intent(inout) :: self
character(:), allocatable :: logo
logo = self%logo
end function shoe_type_get_logo
function shoe_type_get_size(self) result(size)
class(shoe_type), intent(inout) :: self
integer(int8) :: size
size = self%size
end function shoe_type_get_size
subroutine shirt_type_set_logo(self, logo)
class(shirt_type), intent(inout) :: self
character(*), intent(in) :: logo
self%logo = logo
end subroutine shirt_type_set_logo
subroutine shirt_type_set_size(self, size)
class(shirt_type), intent(inout) :: self
integer(int8), intent(in) :: size
self%size = size
end subroutine shirt_type_set_size
function shirt_type_get_logo(self) result(logo)
class(shirt_type), intent(inout) :: self
character(:), allocatable :: logo
logo = self%logo
end function shirt_type_get_logo
function shirt_type_get_size(self) result(size)
class(shirt_type), intent(inout) :: self
integer(int8) :: size
size = self%size
end function shirt_type_get_size
end module abstract_factory_module
program abstract_factory_main
use, intrinsic :: iso_fortran_env, only: int8
use abstract_factory_module, only: isports_factory_type, erke_type, lining_type, get_sports_factory, erke_shoe_type, &
erke_shirt_type, lining_shoe_type, lining_shirt_type, ishoe_type, ishirt_type
class(isports_factory_type), allocatable :: erke_factory, lining_factory
class(ishoe_type), allocatable :: erke_shoe
class(ishirt_type), allocatable :: erke_shirt
class(ishoe_type), allocatable :: lining_shoe
class(ishirt_type), allocatable :: lining_shirt
! allocate (erke_t :: erke_factory)
! allocate (lining_t :: lining_factory)
erke_factory = get_sports_factory("erke")
lining_factory = get_sports_factory("lining")
! allocate (erke_shoe_t :: erke_shoe)
! allocate (erke_shirt_t :: erke_shirt)
! allocate (lining_shoe_t :: lining_shoe)
! allocate (lining_shirt_t :: lining_shirt)
erke_shoe = erke_factory%make_shoe()
erke_shirt = erke_factory%make_shirt()
lining_shoe = lining_factory%make_shoe()
lining_shirt = lining_factory%make_shirt()
call print_shoe_details(erke_shoe)
call print_shirt_details(erke_shirt)
call print_shoe_details(lining_shoe)
call print_shirt_details(lining_shirt)
contains
subroutine print_shoe_details(ishoe)
class(ishoe_type), intent(inout) :: ishoe
print *, "This is a pair of shoes👟."
print *, "Logo: ", ishoe%get_logo()
print *, "Size: ", ishoe%get_size()
end subroutine print_shoe_details
subroutine print_shirt_details(ishirt)
class(ishirt_type), intent(inout) :: ishirt
print *, "This is a T-shirt👕."
print *, "Logo: ", ishirt%get_logo()
print *, "Size: ", ishirt%get_size()
end subroutine print_shirt_details
end program abstract_factory_main
!> Results shall be:
! This is a pair of shoes👟.
! Logo: erke
! Size: 14
! This is a T-shirt👕.
! Logo: erke
! Size: 14
! This is a pair of shoes👟.
! Logo: lining
! Size: 14
! This is a T-shirt👕.
! Logo: lining
! Size: 14
生成器模式
正文：https://refactoringguru.cn/design-patterns/builder
Go代码：https://refactoringguru.cn/design-patterns/builder/go/example
module builder_module
use, intrinsic :: iso_fortran_env, only: int8
implicit none
private
public :: ibuilder_type, director_type, house_type, get_builder
type, abstract :: ibuilder_type
contains
procedure(ibuilder_type_set_window_type), deferred :: set_window_type
procedure(ibuilder_type_set_door_type), deferred :: set_door_type
procedure(ibuilder_type_set_num_floor), deferred :: set_num_floor
procedure(ibuilder_type_get_house), deferred :: get_house
end type ibuilder_type
type, extends(ibuilder_type) :: normal_builder_type
character(:), allocatable :: window_type
character(:), allocatable :: door_type
integer(int8) :: floor
contains
procedure :: set_window_type => normal_builder_type_set_window_type
procedure :: set_door_type => normal_builder_type_set_door_type
procedure :: set_num_floor => normal_builder_type_set_num_floor
procedure :: get_house => normal_builder_type_get_house
end type normal_builder_type
type, extends(ibuilder_type) :: igloo_builder_type
character(:), allocatable :: window_type
character(:), allocatable :: door_type
integer(int8) :: floor
contains
procedure :: set_window_type => igloo_builder_type_set_window_type
procedure :: set_door_type => igloo_builder_type_set_door_type
procedure :: set_num_floor => igloo_builder_type_set_num_floor
procedure :: get_house => igloo_builder_type_get_house
end type igloo_builder_type
type house_type
character(:), allocatable :: window_type
character(:), allocatable :: door_type
integer(int8) :: floor
end type house_type
type director_type
class(ibuilder_type), pointer :: builder
contains
procedure :: set_builder => director_type_set_builder
procedure :: build_house => director_type_build_house
end type director_type
abstract interface
subroutine ibuilder_type_set_window_type(self)
import ibuilder_type
class(ibuilder_type), intent(inout) :: self
end subroutine ibuilder_type_set_window_type
subroutine ibuilder_type_set_door_type(self)
import ibuilder_type
class(ibuilder_type), intent(inout) :: self
end subroutine ibuilder_type_set_door_type
subroutine ibuilder_type_set_num_floor(self)
import ibuilder_type
class(ibuilder_type), intent(inout) :: self
end subroutine ibuilder_type_set_num_floor
function ibuilder_type_get_house(self) result(house)
import ibuilder_type, house_type
class(ibuilder_type), intent(inout) :: self
type(house_type) :: house
end function ibuilder_type_get_house
end interface
contains
function get_builder(builder_type) result(ibuilder)
character(*), intent(in) :: builder_type
class(ibuilder_type), allocatable :: ibuilder
select case (builder_type)
case ("normal")
allocate (normal_builder_type :: ibuilder)
case ("igloo")
allocate (igloo_builder_type :: ibuilder)
end select
end function get_builder
! - - - - - - - - - -
subroutine normal_builder_type_set_window_type(self)
class(normal_builder_type), intent(inout) :: self
self%window_type = "Wooden Window"
end subroutine normal_builder_type_set_window_type
subroutine normal_builder_type_set_door_type(self)
class(normal_builder_type), intent(inout) :: self
self%door_type = "Wooden Door"
end subroutine normal_builder_type_set_door_type
subroutine normal_builder_type_set_num_floor(self)
class(normal_builder_type), intent(inout) :: self
self%floor = 2_int8
end subroutine normal_builder_type_set_num_floor
function normal_builder_type_get_house(self) result(house)
class(normal_builder_type), intent(inout) :: self
type(house_type) :: house
! TODO: A GFortran Bug Here.
! house = house_t(door_type=self%door_type, &
! window_type=self%window_type, &
! floor=self%floor)
house%door_type = self%door_type
house%window_type = self%window_type
house%floor = self%floor
end function normal_builder_type_get_house
! - - - - - - - - - -
subroutine igloo_builder_type_set_window_type(self)
class(igloo_builder_type), intent(inout) :: self
self%window_type = "Snow Window"
end subroutine igloo_builder_type_set_window_type
subroutine igloo_builder_type_set_door_type(self)
class(igloo_builder_type), intent(inout) :: self
self%door_type = "Snow Door"
end subroutine igloo_builder_type_set_door_type
subroutine igloo_builder_type_set_num_floor(self)
class(igloo_builder_type), intent(inout) :: self
self%floor = 1_int8
end subroutine igloo_builder_type_set_num_floor
function igloo_builder_type_get_house(self) result(house)
class(igloo_builder_type), intent(inout) :: self
type(house_type) :: house
! house = house_t(door_type=self%door_type, &
! window_type=self%window_type, &
! floor=self%floor)
house%door_type = self%door_type
house%window_type = self%window_type
house%floor = self%floor
end function igloo_builder_type_get_house
! - - - - - - - - - -
subroutine director_type_set_builder(self, b)
class(director_type), intent(inout) :: self
class(ibuilder_type), intent(inout), target :: b
self%builder => b
end subroutine director_type_set_builder
function director_type_build_house(self) result(house)
class(director_type), intent(inout) :: self
type(house_type) :: house
call self%builder%set_door_type()
call self%builder%set_window_type()
call self%builder%set_num_floor()
house = self%builder%get_house()
end function director_type_build_house
end module builder_module
program builder_main
use builder_module, only: ibuilder_type, director_type, house_type, get_builder
implicit none
class(ibuilder_type), allocatable :: normal_builder, igloo_builder
type(director_type) :: director
type(house_type) :: normal_house, igloo_house
normal_builder = get_builder("normal")
igloo_builder = get_builder("igloo")
!> Normal House
call director%set_builder(normal_builder)
normal_house = director%build_house()
print *, "Normal House Door Type: ", normal_house%door_type
print *, "Normal House Window Type: ", normal_house%window_type
print *, "Normal House Num Floor: ", normal_house%floor
!> Igloo House
call director%set_builder(igloo_builder)
igloo_house = director%build_house()
print *, "Igloo House Door Type: ", igloo_house%door_type
print *, "Igloo House Window Type: ", igloo_house%window_type
print *, "Igloo House Num Floor: ", igloo_house%floor
end program builder_main
!> Results shall be:
! Normal House Door Type: Wooden Door
! Normal House Window Type: Wooden Window
! Normal House Num Floor: 2
! Igloo House Door Type: Snow Door
! Igloo House Window Type: Snow Window
! Igloo House Num Floor: 1
使用默认结构体构造函数来赋值可分配字符型类型的子元素，在GFortran上出现bug，ifort正常：
! TODO: A GFortran Bug Here.
! house = house_t(door_type=self%door_type, &
! window_type=self%window_type, &
! floor=self%floor)
house%door_type = self%door_type
house%window_type = self%window_type
house%floor = self%floor
工厂模式
正文：https://refactoringguru.cn/design-patterns/factory
Go代码：https://refactoringguru.cn/design-patterns/factory/go/example
module factory_module
use, intrinsic :: iso_fortran_env, only: int8
implicit none
private
public :: igun_type, ak47_type, musket_type, get_gun
type, abstract :: igun_type
contains
procedure(igun_type_set_name), deferred :: set_name
procedure(igun_type_set_power), deferred :: set_power
procedure(igun_type_get_name), deferred :: get_name
procedure(igun_type_get_power), deferred :: get_power
end type igun_type
abstract interface
subroutine igun_type_set_name(self, name)
import igun_type
class(igun_type), intent(inout) :: self
character(*), intent(in) :: name
end subroutine igun_type_set_name
subroutine igun_type_set_power(self, power)
import igun_type, int8
class(igun_type), intent(inout) :: self
integer(int8), intent(in) :: power
end subroutine igun_type_set_power
function igun_type_get_name(self) result(name)
import igun_type
class(igun_type), intent(inout) :: self
character(:), allocatable :: name
end function igun_type_get_name
function igun_type_get_power(self) result(power)
import igun_type, int8
class(igun_type), intent(inout) :: self
integer(int8) :: power
end function igun_type_get_power
end interface
type, extends(igun_type) :: gun_type
character(:), allocatable :: name
integer(int8) :: power
contains
procedure :: set_name => gun_type_set_name
procedure :: get_name => gun_type_get_name
procedure :: set_power => gun_type_set_power
procedure :: get_power => gun_type_get_power
end type gun_type
type, extends(gun_type) :: ak47_type
end type ak47_type
type, extends(gun_type) :: musket_type
end type musket_type
contains
subroutine gun_type_set_name(self, name)
class(gun_type), intent(inout) :: self
character(*), intent(in) :: name
self%name = name
end subroutine gun_type_set_name
subroutine gun_type_set_power(self, power)
class(gun_type), intent(inout) :: self
integer(int8), intent(in) :: power
self%power = power
end subroutine gun_type_set_power
function gun_type_get_name(self) result(name)
class(gun_type), intent(inout) :: self
character(:), allocatable :: name
name = self%name
end function gun_type_get_name
function gun_type_get_power(self) result(power)
class(gun_type), intent(inout) :: self
integer(int8) :: power
power = self%power
end function gun_type_get_power
function get_gun(gun_type) result(igun)
character(*), intent(in) :: gun_type
class(igun_type), allocatable :: igun
select case (gun_type)
case ("ak47")
igun = ak47_type(name="ak47 gun", power=4)
case ("musket")
igun = musket_type(name="musket gun", power=1)
case default
error stop "*ERROR* `gnu_type` not supported"
end select
end function get_gun
end module factory_module
program factory_main
use factory_module, only: igun_type, ak47_type, musket_type, get_gun
implicit none
class(igun_type), allocatable :: ak47, musket
allocate (ak47_type :: ak47)
allocate (musket_type :: musket)
ak47 = get_gun("ak47")
musket = get_gun("musket")
call print_details(ak47)
call print_details(musket)
contains
subroutine print_details(igun)
class(igun_type), intent(inout) :: igun
print *, "Gun: ", igun%get_name()
print *, "Power: ", igun%get_power()
end subroutine print_details
end program factory_main
!> Results shall be:
! Gun: ak47 gun
! Power: 4
! Gun: musket gun
! Power: 1
原型模式
正文：https://refactoringguru.cn/design-patterns/prototype
Go代码：https://refactoringguru.cn/design-patterns/prototype/go/example
module prototype_module
implicit none
private
public :: file_type, folder_type, inode_type
type, abstract :: inode_type
contains
procedure(inode_type_print), deferred :: print
procedure(inode_type_clone), deferred :: clone
end type inode_type
type, extends(inode_type) :: file_type
character(:), allocatable :: name
contains
procedure :: print => file_type_print
procedure :: clone => file_type_clone
end type file_type
!> Wrapper (Important)
type node_type
class(inode_type), pointer :: inode
end type node_type
type, extends(inode_type) :: folder_type
type(node_type), allocatable :: children(:)
character(:), allocatable :: name
contains
procedure :: print => folder_type_print
procedure :: clone => folder_type_clone
end type folder_type
abstract interface
subroutine inode_type_print(self, indentation)
import inode_type
class(inode_type), intent(inout) :: self
character(*), intent(in) :: indentation
end subroutine inode_type_print
function inode_type_clone(self) result(inode)
import inode_type
class(inode_type), intent(inout) :: self
class(inode_type), allocatable :: inode
end function inode_type_clone
end interface
contains
subroutine file_type_print(self, indentation)
class(file_type), intent(inout) :: self
character(*), intent(in) :: indentation
print *, indentation//self%name
end subroutine file_type_print
function file_type_clone(self) result(inode)
class(file_type), intent(inout) :: self
class(inode_type), allocatable :: inode
allocate (file_type :: inode)
inode = file_type(name=self%name//"_clone")
end function file_type_clone
! - - - - - - - - -
subroutine folder_type_print(self, indentation)
class(folder_type), intent(inout) :: self
character(*), intent(in) :: indentation
integer :: i
print *, indentation//self%name
if (size(self%children) == 0) return
do i = 1, size(self%children)
call self%children(i)%inode%print(indentation//indentation)
end do
end subroutine folder_type_print
!> There may be incorrect usage here, but I have no choice but to do so.
!> Fortran's compilation check is stricter, and I am indeed bypassing it.
function folder_type_clone(self) result(inode)
class(folder_type), intent(inout) :: self
class(inode_type), allocatable :: inode
type(folder_type), allocatable :: tmp_folder
integer :: i
allocate (tmp_folder, source=self)
tmp_folder%name = tmp_folder%name//"_clone"
if (size(self%children) > 0) then
do i = 1, size(tmp_folder%children)
associate (node => tmp_folder%children(i)%inode)
inode = node%clone()
allocate (tmp_folder%children(i)%inode, source=inode)
end associate
end do
end if
call move_alloc(tmp_folder, inode)
end function folder_type_clone
end module prototype_module
program prototype_main
use prototype_module, only: file_type, folder_type, inode_type
implicit none
type(file_type), target :: file1, file2, file3
type(folder_type), target :: folder1
type(folder_type) :: folder2
class(inode_type), allocatable :: clone_folder
file1%name = "file1"
file2%name = "file2"
file3%name = "file3"
folder1%name = "folder1"
allocate (folder1%children(1))
folder1%children(1)%inode => file1
folder2%name = "folder2"
allocate (folder2%children(3))
folder2%children(1)%inode => folder1
folder2%children(2)%inode => file2
folder2%children(3)%inode => file3
print *, "Printing hierarchy for Folder2"
call folder2%print(" ")
clone_folder = folder2%clone()
print *, "Printing hierarchy for clone Folder"
call clone_folder%print(" ")
end program prototype_main
!> Results shall be:
! Printing hierarchy for Folder2
! folder2
! folder1
! file1
! file2
! file3
! Printing hierarchy for clone Folder
! folder2_clone
! folder1_clone
! file1_clone
! file2_clone
! file3_clone
单例模式
正文：https://refactoringguru.cn/design-patterns/singleton
module singleton_module
implicit none
private
public :: single, get_instance, dispose_instance
logical :: lock = .false.
type single_type
private
integer :: value
end type single_type
type(single_type) :: single
contains
function get_instance(value) result(single)
integer, intent(in) :: value
type(single_type) :: single
if (lock) then
print *, "Single instance already created."
return
else
print *, "Creating single instance now."
single%value = value
lock = .true.
end if
end function get_instance
subroutine dispose_instance(single)
type(single_type), intent(inout) :: single
print *, "Disposing single instance now."
single%value = 0
lock = .false.
end subroutine dispose_instance
end module singleton_module
program singleton_main
use singleton_module, only: single, get_instance, dispose_instance
implicit none
single = get_instance(10)
single = get_instance(23)
single = get_instance(0)
call dispose_instance(single)
single = get_instance(9)
end program singleton_main
适配器模式
正文：https://refactoringguru.cn/design-patterns/adapter
Go代码：https://refactoringguru.cn/design-patterns/adapter/go/example
module adapter_module
implicit none
private
public :: client_type, computer_type, mac_type, windows_type, windows_adapter_type
type client_type
contains
procedure :: insert_lightning_connector_into_computer => client_type_insert_lightning_connector_into_computer
end type client_type
type, abstract :: computer_type
contains
procedure(computer_type_insert_into_lightning_port), deferred :: insert_into_lightning_port
end type computer_type
type, extends(computer_type) :: mac_type
contains
procedure :: insert_into_lightning_port => mac_type_insert_into_lightning_port
end type mac_type
type, extends(computer_type) :: windows_type
contains
procedure :: insert_into_lightning_port => windows_type_insert_into_lightning_port
end type windows_type
type, extends(computer_type) :: windows_adapter_type
type(windows_type), pointer :: windows_machine
contains
procedure :: insert_into_lightning_port => windows_adapter_type_insert_into_lightning_port
end type windows_adapter_type
abstract interface
subroutine computer_type_insert_into_lightning_port(self)
import computer_type
class(computer_type), intent(inout) :: self
end subroutine computer_type_insert_into_lightning_port
end interface
contains
subroutine client_type_insert_lightning_connector_into_computer(self, com)
class(client_type), intent(inout) :: self
class(computer_type), intent(inout) :: com
print *, "Client inserts Lightning connector into computer."
call com%insert_into_lightning_port()
end subroutine client_type_insert_lightning_connector_into_computer
subroutine mac_type_insert_into_lightning_port(self)
class(mac_type), intent(inout) :: self
print *, "Lightning connector is plugged into mac machine."
end subroutine mac_type_insert_into_lightning_port
subroutine windows_type_insert_into_lightning_port(self)
class(windows_type), intent(inout) :: self
print *, "USB connector is plugged into windows machine."
end subroutine windows_type_insert_into_lightning_port
subroutine windows_adapter_type_insert_into_lightning_port(self)
class(windows_adapter_type), intent(inout) :: self
print *, "Adapter converts Lightning signal to USB."
call self%windows_machine%insert_into_lightning_port()
end subroutine windows_adapter_type_insert_into_lightning_port
end module adapter_module
program adapter_main
use adapter_module, only: client_type, computer_type, mac_type, windows_type, windows_adapter_type
implicit none
type(client_type) :: client
type(mac_type) :: mac
type(windows_type), target :: windows
type(windows_adapter_type) :: windows_adapter
call client%insert_lightning_connector_into_computer(mac)
windows_adapter%windows_machine => windows
call client%insert_lightning_connector_into_computer(windows_adapter)
end program adapter_main
!> Results shall be:
! Client inserts Lightning connector into computer.
! Lightning connector is plugged into mac machine.
! Client inserts Lightning connector into computer.
! Adapter converts Lightning signal to USB.
! USB connector is plugged into windows machine.
桥接模式
正文：https://refactoringguru.cn/design-patterns/bridge
Go代码：https://refactoringguru.cn/design-patterns/bridge/go/example
module bridge_module
implicit none
private
public :: hp_type, epson_type, mac_type, windows_type
type, abstract :: computer_type
contains
procedure(computer_type_print), deferred :: print
procedure(computer_type_set_printer), deferred :: set_printer
end type computer_type
type, abstract :: printer_type
contains
procedure(printer_type_print_file), deferred :: print_file
end type printer_type
abstract interface
subroutine computer_type_print(self)
import computer_type
class(computer_type), intent(inout) :: self
end subroutine computer_type_print
subroutine computer_type_set_printer(self, printer)
import computer_type, printer_type
class(computer_type), intent(inout) :: self
class(printer_type), intent(inout), target :: printer
end subroutine computer_type_set_printer
subroutine printer_type_print_file(self)
import printer_type
class(printer_type), intent(inout) :: self
end subroutine printer_type_print_file
end interface
type, extends(printer_type) :: epson_type
contains
procedure :: print_file => epson_type_print_file
end type epson_type
type, extends(printer_type) :: hp_type
contains
procedure :: print_file => hp_type_print_file
end type hp_type
type, extends(computer_type) :: mac_type
class(printer_type), pointer :: printer
contains
procedure :: print => mac_type_print
procedure :: set_printer => mac_type_set_printer
end type mac_type
type, extends(computer_type) :: windows_type
class(printer_type), pointer :: printer
contains
procedure :: print => windows_type_print
procedure :: set_printer => windows_type_set_printer
end type windows_type
contains
subroutine windows_type_print(self)
class(windows_type), intent(inout) :: self
print *, "Print request for windows"
call self%printer%print_file()
end subroutine windows_type_print
subroutine windows_type_set_printer(self, printer)
class(windows_type), intent(inout) :: self
class(printer_type), intent(inout), target :: printer
self%printer => printer
end subroutine windows_type_set_printer
subroutine mac_type_print(self)
class(mac_type), intent(inout) :: self
print *, "Print request for mac"
call self%printer%print_file()
end subroutine mac_type_print
subroutine mac_type_set_printer(self, printer)
class(mac_type), intent(inout) :: self
class(printer_type), intent(inout), target :: printer
self%printer => printer
end subroutine mac_type_set_printer
subroutine epson_type_print_file(self)
class(epson_type), intent(inout) :: self
print *, "Printing by a EPSON Printer"
end subroutine epson_type_print_file
subroutine hp_type_print_file(self)
class(hp_type), intent(inout) :: self
print *, "Printing by a HP Printer"
end subroutine hp_type_print_file
end module bridge_module
program bridge_main
use bridge_module, only: hp_type, epson_type, mac_type, windows_type
implicit none
type(hp_type) :: hp_printer
type(epson_type) :: epson_printer
type(mac_type) :: mac_computer
type(windows_type) :: windows_computer
call mac_computer%set_printer(hp_printer)
call mac_computer%print()
call mac_computer%set_printer(epson_printer)
call mac_computer%print()
call windows_computer%set_printer(hp_printer)
call windows_computer%print()
call windows_computer%set_printer(epson_printer)
call windows_computer%print()
end program bridge_main
!> Results shall be:
! Print request for mac
! Printing by a HP Printer
! Print request for mac
! Printing by a EPSON Printer
! Print request for windows
! Printing by a HP Printer
! Print request for windows
! Printing by a EPSON Printer
享元模式
正文：https://refactoringguru.cn/design-patterns/flyweight
Go代码：https://zhuanlan.zhihu.com/p/343999246
module cache_module
implicit none
private
public :: cache_type, cache_factory_type
type, abstract :: cache_type
contains
procedure(cache_type_operation), deferred :: operation
end type cache_type
abstract interface
subroutine cache_type_operation(self)
import cache_type
class(cache_type), intent(inout) :: self
end subroutine cache_type_operation
end interface
type, extends(cache_type) :: concrete_cache_type
character(:), allocatable :: key
contains
procedure :: operation => concrete_cache_type_operation
end type concrete_cache_type
type node_type
class(cache_type), allocatable :: cache
end type node_type
type cache_factory_type
type(node_type), allocatable :: cache_list(:)
contains
procedure :: get_cache => cache_factory_type_get_cache
end type cache_factory_type
contains
subroutine concrete_cache_type_operation(self)
class(concrete_cache_type), intent(inout) :: self
print *, self%key
end subroutine concrete_cache_type_operation
function cache_factory_type_get_cache(self, key) result(cache)
class(cache_factory_type), intent(inout), target :: self
character(*), intent(in) :: key
class(cache_type), pointer :: cache
integer :: i
if (allocated(self%cache_list)) then
do i = 1, size(self%cache_list)
associate (cache_ => self%cache_list(i)%cache)
select type (cache_)
type is (concrete_cache_type)
if (cache_%key == key) then
cache => self%cache_list(i)%cache
return
end if
end select
end associate
end do
end if
self%cache_list = append_slice(self%cache_list, key)
cache => self%cache_list(size(self%cache_list))%cache
end function cache_factory_type_get_cache
!> Date structure
function append_slice(cache_list_in, key) result(cache_list_out)
type(node_type), intent(inout), allocatable :: cache_list_in(:)
character(*), intent(in) :: key
type(node_type), allocatable :: cache_list_out(:)
integer :: i
if (.not. allocated(cache_list_in)) then
allocate (cache_list_out(1))
allocate (cache_list_out(1)%cache, source=concrete_cache_type(key=key))
else
i = size(cache_list_in)
allocate (cache_list_out(i + 1))
cache_list_out(1:i) = cache_list_in
allocate (cache_list_out(i + 1)%cache, source=concrete_cache_type(key=key))
end if
end function append_slice
end module cache_module
program cache_main
use cache_module, only: cache_factory_type, cache_type
implicit none
type(cache_factory_type) factory
class(cache_type), pointer :: cache
cache => factory%get_cache("A")
call cache%operation()
cache => factory%get_cache("A")
call cache%operation()
cache => factory%get_cache("B")
call cache%operation()
cache => factory%get_cache("C")
call cache%operation()
print *, "List length: ", size(factory%cache_list)
end program cache_main
!> Results shall be:
! A
! A
! B
! C
! List length: 3
组合模式
正文：https://refactoringguru.cn/design-patterns/composite
Go代码：https://refactoringguru.cn/design-patterns/composite/go/example
module composite_module
implicit none
private
public :: file_type, folder_type
type, abstract :: component_type
contains
procedure(component_type_search), deferred :: search
end type component_type
type, extends(component_type) :: file_type
character(:), allocatable :: name
contains
procedure :: search => file_type_search
procedure :: get_name => file_type_get_name
end type file_type
type node_t
class(component_type), pointer :: node
end type node_t
type, extends(component_type) :: folder_type
type(node_t), allocatable :: components(:)
character(:), allocatable :: name
contains
procedure :: search => folder_type_search
end type folder_type
abstract interface
subroutine component_type_search(self, keyward)
import component_type
class(component_type), intent(inout) :: self
character(*), intent(in) :: keyward
end subroutine component_type_search
end interface
contains
subroutine file_type_search(self, keyward)
class(file_type), intent(inout) :: self
character(*), intent(in) :: keyward
print *, "Searching for keyword ", keyward, " in file ", self%name
end subroutine file_type_search
function file_type_get_name(self) result(name)
class(file_type), intent(inout) :: self
character(:), allocatable :: name
name = self%name
end function file_type_get_name
! - - - - - - - - - -
subroutine folder_type_search(self, keyward)
class(folder_type), intent(inout) :: self
character(*), intent(in) :: keyward
integer :: i
print *, "Searching recursively for keyword ", keyward, " in folder ", self%name
if (size(self%components) == 0) return
do i = 1, size(self%components)
call self%components(i)%node%search(keyward)
end do
end subroutine folder_type_search
end module composite_module
program composite_main
use composite_module, only: file_type, folder_type
implicit none
type(file_type), target :: file1, file2, file3
type(folder_type), target :: folder1
type(folder_type) :: folder2
file1%name = "File1"
file2%name = "File2"
file3%name = "File3"
folder1%name = "Folder1"
folder2%name = "Folder2"
allocate (folder1%components(1))
folder1%components(1)%node => file1
allocate (folder2%components(3))
folder2%components(1)%node => file2
folder2%components(2)%node => file3
folder2%components(3)%node => folder1
call folder2%search("rose")
end program composite_main
!> Results shall be:
! Searching recursively for keyword rose in folder Folder2
! Searching for keyword rose in file File2
! Searching for keyword rose in file File3
! Searching recursively for keyword rose in folder Folder1
! Searching for keyword rose in file File1
外观模式
正文：https://refactoringguru.cn/design-patterns/facade
Go代码：https://refactoringguru.cn/design-patterns/facade/go/example
module facade_module
implicit none
private
public :: new_wallet_facade, wallet_facade_type
type account_type
character(:), allocatable :: name
contains
procedure :: check_account => account_type_check_account
end type account_type
type security_code_type
integer :: code
contains
procedure :: check_code => security_code_type_check_code
end type security_code_type
type wallet_type
integer :: balance
contains
procedure :: credit_balance => wallet_type_credit_balance
procedure :: debit_balance => wallet_type_debit_balance
end type wallet_type
type ledger_type
contains
procedure :: make_entry => ledger_type_make_entry
end type ledger_type
type notification_type
contains
procedure :: send_wallet_credit_notification => notification_type_send_wallet_credit_notification
procedure :: send_wallet_debit_notification => notification_type_send_wallet_debit_notification
end type notification_type
type wallet_facade_type
type(account_type) :: account
type(wallet_type) :: wallet
type(security_code_type) :: security_code
type(notification_type) :: notification
type(ledger_type) :: ledger
contains
procedure :: add_money_to_wallet => wallet_facade_type_add_money_to_wallet
procedure :: deduct_money_from_wallet => wallet_facade_type_deduct_money_from_wallet
end type wallet_facade_type
contains
function new_wallet_facade(account_id, code) result(wallet_facade)
character(*), intent(in) :: account_id
integer, intent(in) :: code
type(wallet_facade_type) :: wallet_facade
print *, "Starting create account"
wallet_facade = wallet_facade_type(account=account_type(account_id), &
security_code=security_code_type(code), &
wallet=wallet_type(balance=0), &
notification=notification_type(), &
ledger=ledger_type())
print *, "Account created"
end function new_wallet_facade
subroutine wallet_facade_type_add_money_to_wallet(self, account_id, security_code, amount)
class(wallet_facade_type), intent(inout) :: self
character(*), intent(in) :: account_id
integer, intent(in) :: security_code, amount
print *, "Starting add money to wallet"
call self%account%check_account(account_id)
call self%security_code%check_code(security_code)
call self%wallet%credit_balance(amount)
call self%notification%send_wallet_credit_notification()
call self%ledger%make_entry(account_id, "credit", amount)
end subroutine wallet_facade_type_add_money_to_wallet
subroutine wallet_facade_type_deduct_money_from_wallet(self, account_id, security_code, amount)
class(wallet_facade_type), intent(inout) :: self
character(*), intent(in) :: account_id
integer, intent(in) :: security_code, amount
print *, "Starting debit money from wallet"
call self%account%check_account(account_id)
call self%security_code%check_code(security_code)
call self%wallet%credit_balance(amount)
call self%notification%send_wallet_credit_notification()
call self%ledger%make_entry(account_id, "credit", amount)
end subroutine wallet_facade_type_deduct_money_from_wallet
! - - - - - - - - -
subroutine account_type_check_account(self, account_name)
class(account_type), intent(inout) :: self
character(*), intent(in) :: account_name
if (self%name /= account_name) then
error stop "Account Name is incorrect"
end if
print *, "Account Verified"
end subroutine account_type_check_account
! - - - - - - - - -
subroutine security_code_type_check_code(self, incomming_code)
class(security_code_type), intent(inout) :: self
integer, intent(in) :: incomming_code
if (self%code /= incomming_code) then
error stop "Security Code is incorrect"
end if
print *, "SecurityCode Verified"
end subroutine security_code_type_check_code
! - - - - - - - - -
subroutine wallet_type_credit_balance(self, amount)
class(wallet_type), intent(inout) :: self
integer, intent(in) :: amount
self%balance = self%balance + amount
print *, "Wallet balance added successfully"
end subroutine wallet_type_credit_balance
subroutine wallet_type_debit_balance(self, amount)
class(wallet_type), intent(inout) :: self
integer, intent(in) :: amount
if (self%balance < amount) then
error stop "Balance is not sufficient"
end if
print *, "Wallet balance is Sufficient"
self%balance = self%balance - amount
end subroutine wallet_type_debit_balance
! - - - - - - - - -
subroutine ledger_type_make_entry(self, account_id, txn_type, amount)
class(ledger_type), intent(inout) :: self
character(*), intent(in) :: account_id, txn_type
integer, intent(in) :: amount
print *, "Make ledger entry for accountId ", account_id, &
" with txnType ", txn_type, &
" for amount ", amount
end subroutine ledger_type_make_entry
! - - - - - - - - -
subroutine notification_type_send_wallet_credit_notification(self)
class(notification_type), intent(inout) :: self
print *, "Sending wallet credit notification"
end subroutine notification_type_send_wallet_credit_notification
subroutine notification_type_send_wallet_debit_notification(self)
class(notification_type), intent(inout) :: self
print *, "Sending wallet debit notification"
end subroutine notification_type_send_wallet_debit_notification
end module facade_module
program facade_main
use facade_module, only: wallet_facade_type, new_wallet_facade
implicit none
type(wallet_facade_type) :: wallet_facade
wallet_facade = new_wallet_facade(account_id="abc", code=1234)
call wallet_facade%add_money_to_wallet(account_id="abc", security_code=1234, amount=10)
call wallet_facade%deduct_money_from_wallet(account_id="abc", security_code=1234, amount=5)
end program facade_main
!> Results shall be:
! Starting create account
! Account created
! Starting add money to wallet
! Account Verified
! SecurityCode Verified
! Wallet balance added successfully
! Sending wallet credit notification
! Make ledger entry for accountId abc with txnType credit for amount 10
! Starting debit money from wallet
! Account Verified
! SecurityCode Verified
! Wallet balance added successfully
! Sending wallet credit notification
! Make ledger entry for accountId abc with txnType credit for amount 5
代理模式
正文：https://refactoringguru.cn/design-patterns/proxy
Go代码：https://refactoringguru.cn/design-patterns/proxy/go/example
module proxy_module
use, intrinsic :: iso_fortran_env, only: int16
implicit none
private
public :: nginx_type, new_nginx_server
type, abstract :: server_type
contains
procedure(server_type_handle_request), deferred :: handle_request
end type server_type
abstract interface
subroutine server_type_handle_request(self, url, method, code, msg)
import server_type, int16
class(server_type), intent(inout) :: self
character(*), intent(in) :: url, method
integer(int16), intent(out) :: code
character(:), intent(out), allocatable :: msg
end subroutine server_type_handle_request
end interface
type map_type
character(:), allocatable :: url
integer(int16) :: rate_limiter
end type map_type
type, extends(server_type) :: nginx_type
type(application_type), allocatable :: application
integer(int16) :: max_allowed_request
type(map_type), allocatable :: map(:)
! TODO:
contains
procedure :: handle_request => nginx_t_handle_request
procedure :: check_rate_limiting => nginx_t_check_rate_limiting
end type nginx_type
type, extends(server_type) :: application_type
contains
procedure :: handle_request => application_t_handle_request
end type application_type
contains
type(nginx_type) function new_nginx_server() result(nginx)
type(map_type), allocatable :: map_(:)
! TODO:
allocate (map_(2))
map_(1) = map_type(url="/app/status", rate_limiter=0_int16)
map_(2) = map_type(url="/create/user", rate_limiter=0_int16)
nginx = nginx_type(application=application_type(), max_allowed_request=2, map=map_) ! TODO:
end function new_nginx_server
subroutine nginx_t_handle_request(self, url, method, code, msg)
class(nginx_type), intent(inout) :: self
character(*), intent(in) :: url, method
integer(int16), intent(out) :: code
character(:), intent(out), allocatable :: msg
logical :: allowed
allowed = self%check_rate_limiting(url)
if (.not. allowed) then
code = 403_int16
msg = "Not Allowed"
return
end if
call self%application%handle_request(url, method, code, msg)
end subroutine nginx_t_handle_request
logical function nginx_t_check_rate_limiting(self, url) result(allowed)
class(nginx_type), intent(inout) :: self
character(*), intent(in) :: url
integer(int16) :: i
do i = 1_int16, size(self%map, kind=int16)
if (self%map(i)%url == url) exit
end do
! i = i - 1_int16
if (self%map(i)%rate_limiter == 0_int16) then
self%map(i)%rate_limiter = 1_int16
end if
if (self%map(i)%rate_limiter > self%max_allowed_request) then
allowed = .false.
return
end if
allowed = .true.
self%map(i)%rate_limiter = self%map(i)%rate_limiter + 1_int16
end function nginx_t_check_rate_limiting
subroutine application_t_handle_request(self, url, method, code, msg)
class(application_type), intent(inout) :: self
character(*), intent(in) :: url, method
integer(int16), intent(out) :: code
character(:), intent(out), allocatable :: msg
if (url == "/app/status" .and. method == "GET") then
code = 200_int16
msg = "Ok"
return
end if
if (url == "/create/user" .and. method == "POST") then
code = 201_int16
msg = "User Created"
return
end if
code = 404_int16
msg = "Not Ok"
end subroutine application_t_handle_request
end module proxy_module
program proxy_main
use, intrinsic :: iso_fortran_env, only: int16
use proxy_module, only: nginx_type, new_nginx_server
type(nginx_type) :: nginx_server
character(*), parameter :: app_status_url = "/app/status", create_user_url = "/create/user"
integer(int16) :: code
character(:), allocatable :: body
nginx_server = new_nginx_server()
call nginx_server%handle_request(app_status_url, "GET", code, body)
print *, "Url: ", app_status_url, new_line(""), &
"Http code: ", code, new_line(""), &
"Body: ", body
call nginx_server%handle_request(app_status_url, "GET", code, body)
print *, "Url: ", app_status_url, new_line(""), &
"Http code: ", code, new_line(""), &
"Body: ", body
call nginx_server%handle_request(app_status_url, "GET", code, body)
print *, "Url: ", app_status_url, new_line(""), &
"Http code: ", code, new_line(""), &
"Body: ", body
call nginx_server%handle_request(create_user_url, "POST", code, body)
print *, "Url: ", create_user_url, new_line(""), &
"Http code: ", code, new_line(""), &
"Body: ", body
call nginx_server%handle_request(create_user_url, "GET", code, body)
print *, "Url: ", create_user_url, new_line(""), &
"Http code: ", code, new_line(""), &
"Body: ", body
end program proxy_main
!> Results shall be:
! Url: /app/status
! Http code: 200
! Body: Ok
! Url: /app/status
! Http code: 200
! Body: Ok
! Url: /app/status
! Http code: 403
! Body: Not Allowed
! Url: /create/user
! Http code: 201
! Body: User Created
! Url: /create/user
! Http code: 404
! Body: Not Ok
装饰模式
正文：https://refactoringguru.cn/design-patterns/decorator
Go代码：https://refactoringguru.cn/design-patterns/decorator/go/example
module wrapper_module
implicit none
private
public :: vegge_mania_type, tomato_topping_type, cheese_topping_type
type, abstract :: pizza_type
contains
procedure(pizza_t_get_price), deferred :: get_price
end type pizza_type
abstract interface
function pizza_t_get_price(self) result(price)
import :: pizza_type
class(pizza_type), intent(inout) :: self
integer :: price
end function pizza_t_get_price
end interface
type, extends(pizza_type) :: vegge_mania_type
contains
procedure :: get_price => vegge_mania_type_get_price
end type vegge_mania_type
type, extends(pizza_type) :: tomato_topping_type
class(pizza_type), pointer :: pizza
contains
procedure :: get_price => tomato_topping_type_get_price
end type tomato_topping_type
type, extends(pizza_type) :: cheese_topping_type
class(pizza_type), pointer :: pizza
contains
procedure :: get_price => cheese_topping_type_get_price
end type cheese_topping_type
contains
function vegge_mania_type_get_price(self) result(price)
class(vegge_mania_type), intent(inout) :: self
integer :: price
price = 15
end function vegge_mania_type_get_price
function tomato_topping_type_get_price(self) result(price)
class(tomato_topping_type), intent(inout) :: self
integer :: price
price = self%pizza%get_price() + 7
end function tomato_topping_type_get_price
function cheese_topping_type_get_price(self) result(price)
class(cheese_topping_type), intent(inout) :: self
integer :: price
price = self%pizza%get_price() + 10
end function cheese_topping_type_get_price
end module wrapper_module
program wrapper_main
use wrapper_module, only: vegge_mania_type, cheese_topping_type, tomato_topping_type
implicit none
type(vegge_mania_type), target :: pizza
type(cheese_topping_type), target :: pizza_with_cheese
type(tomato_topping_type) :: pizza_with_tomato_and_cheese
pizza_with_cheese%pizza => pizza
pizza_with_tomato_and_cheese%pizza => pizza_with_cheese
print *, "Prince of veggeMania with tomato and cheese topping is ", pizza_with_tomato_and_cheese%get_price()
end program wrapper_main
!> Results shall be:
! Prince of veggeMania with tomato and cheese topping is 32.
责任链模式
正文：https://refactoringguru.cn/design-patterns/chain-of-responsibility
Go代码：https://refactoringguru.cn/design-patterns/chain-of-responsibility/go/example
示例
本例子模拟医院的看病缴费的责任链。
病人需要进行的大致步骤是：
- 进院，注册信息
- 医生检查
- 药房给药
- 病人缴费，出院
!> CoR: Hospital departments
module hospital_CoR
implicit none
private
public :: patient_type, department_type, reception_type, doctor_type, medical_type, cashier_type
type patient_type
character(:), allocatable :: name
logical :: registration_done
logical :: doctor_check_up_done
logical :: medicine_done
logical :: payment_done
end type patient_type
type, abstract :: department_type
contains
procedure(execute_procedure), deferred :: execute
procedure(set_next_procedure), deferred :: set_next
end type department_type
abstract interface
subroutine execute_procedure(self, p)
import department_type, patient_type
class(department_type), intent(inout) :: self
type(patient_type), intent(inout) :: p
end subroutine execute_procedure
subroutine set_next_procedure(self, next)
import department_type
class(department_type), intent(inout) :: self
class(department_type), intent(inout) :: next
end subroutine set_next_procedure
end interface
type, extends(department_type) :: reception_type
class(department_type), pointer :: next
contains
procedure :: execute => reception_type_execute
procedure :: set_next => reception_type_set_next
end type reception_type
type, extends(department_type) :: doctor_type
class(department_type), pointer :: next
contains
procedure :: execute => doctor_type_execute
procedure :: set_next => doctor_type_set_next
end type doctor_type
type, extends(department_type) :: medical_type
class(department_type), pointer :: next
contains
procedure :: execute => medicine_type_execute
procedure :: set_next => medicine_type_set_next
end type medical_type
type, extends(department_type) :: cashier_type
class(department_type), pointer :: next
contains
procedure :: execute => cashier_type_execute
procedure :: set_next => cashier_type_set_next
end type cashier_type
contains
subroutine reception_type_execute(self, p)
class(reception_type), intent(inout) :: self
type(patient_type), intent(inout) :: p
if (p%registration_done) then
print *, "Patient registration already done.✔️"
call self%next%execute(p)
return
end if
print *, "Reception registering patient."
p%registration_done = .true.
call self%next%execute(p)
end subroutine reception_type_execute
subroutine reception_type_set_next(self, next)
class(reception_type), intent(inout) :: self
class(department_type), intent(inout) :: next
allocate (self%next, source=next)
end subroutine reception_type_set_next
subroutine doctor_type_execute(self, p)
class(doctor_type), intent(inout) :: self
type(patient_type), intent(inout) :: p
if (p%doctor_check_up_done) then
print *, "Doctor checkup already done.✔️"
call self%next%execute(p)
return
end if
print *, "Doctor checking patient."
p%doctor_check_up_done = .true.
call self%next%execute(p)
end subroutine doctor_type_execute
subroutine doctor_type_set_next(self, next)
class(doctor_type), intent(inout) :: self
class(department_type), intent(inout) :: next
allocate (self%next, source=next)
end subroutine doctor_type_set_next
subroutine medicine_type_execute(self, p)
class(medical_type), intent(inout) :: self
type(patient_type), intent(inout) :: p
if (p%medicine_done) then
print *, "Medicine already given to patient.✔️"
call self%next%execute(p)
return
end if
print *, "Medical giving medicine to patient."
p%medicine_done = .true.
call self%next%execute(p)
end subroutine medicine_type_execute
subroutine medicine_type_set_next(self, next)
class(medical_type), intent(inout) :: self
class(department_type), intent(inout) :: next
allocate (self%next, source=next)
end subroutine medicine_type_set_next
subroutine cashier_type_execute(self, p)
class(cashier_type), intent(inout) :: self
type(patient_type), intent(inout) :: p
if (p%payment_done) then
print *, "Payment Done.✔️"
return
end if
print *, "Cashier getting money from patient."
p%payment_done = .true.
end subroutine cashier_type_execute
subroutine cashier_type_set_next(self, next)
class(cashier_type), intent(inout) :: self
class(department_type), intent(inout) :: next
allocate (self%next, source=next)
end subroutine cashier_type_set_next
end module hospital_CoR
!> CoR: Patient visiting hospital
program CoR_main
use hospital_CoR
type(cashier_type) :: c
type(medical_type) :: m
type(doctor_type) :: d
type(reception_type) :: r
type(patient_type) :: p1, p2
!> Set next for departments
call m%set_next(c)
call d%set_next(m)
call r%set_next(d)
p1 = patient_type("abc", .true., .true., .true., .true.)
!> Patient visiting
print *, "> Patient `"//p1%name//"` : "
call r%execute(p1)
p2 = patient_type("def", .true., .false., .false., .false.)
!> Patient visiting
print *, "> Patient `"//p2%name//"` : "
call r%execute(p2)
!> Optional statements
deallocate (m%next)
deallocate (d%next)
deallocate (r%next)
end program CoR_main
!> Results shall be:
! > Patient `abc` :
! Patient registration already done.✔️
! Doctor checkup already done.✔️
! Medicine already given to patient.✔️
! Payment Done.✔️
! > Patient `def` :
! Patient registration already done.✔️
! Doctor checking patient.
! Medical giving medicine to patient.
! Cashier getting money from patient.
评价
责任链很像流水线，上一节点处理完进入下一节点。
可以应用于科学计算的文件输入检查过程。
命令模式
正文：https://refactoringguru.cn/design-patterns/command
Go代码：https://refactoringguru.cn/design-patterns/command/go/example
!> Reference: https://refactoring.guru/design-patterns/command/go/example
module command_pattern
implicit none
private
public :: tv_type, on_command_type, off_command_type, button_type
!> Abstract classes
type, abstract :: command_type
contains
procedure(execute_procedure), deferred :: execute
end type command_type
type, abstract :: device_type
contains
procedure(on_procedure), deferred :: on
procedure(off_procedure), deferred :: off
end type device_type
abstract interface
subroutine execute_procedure(self)
import command_type
class(command_type), intent(inout) :: self
end subroutine execute_procedure
subroutine on_procedure(self)
import device_type
class(device_type), intent(inout) :: self
end subroutine on_procedure
subroutine off_procedure(self)
import device_type
class(device_type), intent(inout) :: self
end subroutine off_procedure
end interface
!> Specific Objects
type, extends(command_type) :: on_command_type
class(device_type), pointer :: d
contains
procedure :: execute => on_command_type_execute
end type on_command_type
type, extends(command_type) :: off_command_type
class(device_type), pointer :: d
contains
procedure :: execute => off_command_type_execute
end type off_command_type
type, extends(device_type) :: tv_type
logical :: is_running
contains
procedure :: on => tv_type_on
procedure :: off => tv_type_off
end type tv_type
type :: button_type
class(command_type), pointer :: c
contains
procedure :: press
end type button_type
contains
subroutine press(self)
class(button_type), intent(inout) :: self
call self%c%execute()
end subroutine press
subroutine on_command_type_execute(self)
class(on_command_type), intent(inout) :: self
call self%d%on()
end subroutine on_command_type_execute
subroutine off_command_type_execute(self)
class(off_command_type), intent(inout) :: self
call self%d%off()
end subroutine off_command_type_execute
subroutine tv_type_on(self)
class(tv_type), intent(inout) :: self
self%is_running = .true.
print *, "Turning tv on. ✔️"
end subroutine tv_type_on
subroutine tv_type_off(self)
class(tv_type), intent(inout) :: self
self%is_running = .false.
print *, "Turning tv off. ❌"
end subroutine tv_type_off
end module command_pattern
!> Reference: https://refactoring.guru/design-patterns/command/go/example
program test_command
use command_pattern, only: tv_type, on_command_type, off_command_type, button_type
type(tv_type) :: t
type(on_command_type) :: on_c
type(off_command_type) :: off_c
type(button_type) :: on_b
type(button_type) :: off_b
!> Linking
allocate (on_c%d, source=t)
allocate (off_c%d, source=t)
allocate (on_b%c, source=on_c)
allocate (off_b%c, source=off_c)
!> Operating
call on_b%press()
call off_b%press()
!> Free memory.
deallocate (on_c%d)
deallocate (off_c%d)
deallocate (on_b%c)
deallocate (off_b%c)
end program test_command
!> Results shall be:
! Turning tv on. ✔️
! Turning tv off. ❌
迭代器模式
正文：https://refactoringguru.cn/design-patterns/iterator
Go代码：https://refactoringguru.cn/design-patterns/iterator/go/example
module iterator_module
use, intrinsic :: iso_fortran_env, only: int8
implicit none
private
public :: user_type, user_collection_type, user_iterator_type, iterator_type
!> Abstract types
!> Collection
type, abstract :: collection_type
contains
procedure(collection_type_create_iterator), deferred :: create_iterator
end type collection_type
!> Iterator
type, abstract :: iterator_type
contains
procedure(iterator_t_has_next), deferred :: has_next
procedure(iterator_t_get_next), deferred :: get_next
end type iterator_type
!> User
type user_type
character(:), allocatable :: name
integer(int8) :: age
end type user_type
abstract interface
function collection_type_create_iterator(self) result(iterator)
import iterator_type, collection_type
!> TODO:
class(collection_type), intent(in) :: self
class(iterator_type), allocatable :: iterator
end function collection_type_create_iterator
logical function iterator_t_has_next(self)
import iterator_type
class(iterator_type), intent(in) :: self
end function iterator_t_has_next
type(user_type) function iterator_t_get_next(self)
import user_type, iterator_type
class(iterator_type), intent(inout) :: self
end function iterator_t_get_next
end interface
!> Specific types
!> User collection
type, extends(collection_type) :: user_collection_type
type(user_type), allocatable :: users(:)
contains
procedure :: create_iterator => user_collection_t_create_iterator
end type user_collection_type
!> User iterator
type, extends(iterator_type) :: user_iterator_type
integer :: index
type(user_type), allocatable :: users(:)
contains
procedure :: has_next => user_iterator_t_has_next
procedure :: get_next => user_iterator_t_get_next
end type user_iterator_type
contains
function user_collection_t_create_iterator(self) result(iterator)
class(user_collection_type), intent(in) :: self
class(iterator_type), allocatable :: iterator
! TODO:
iterator = user_iterator_type(index=0, users=self%users)
end function user_collection_t_create_iterator
logical function user_iterator_t_has_next(self) result(has)
class(user_iterator_type), intent(in) :: self
has = merge(.true., .false., self%index < size(self%users))
end function user_iterator_t_has_next
type(user_type) function user_iterator_t_get_next(self) result(user)
class(user_iterator_type), intent(inout) :: self
self%index = self%index + 1
user = self%users(self%index)
end function user_iterator_t_get_next
end module iterator_module
program iterator_main
use, intrinsic :: iso_fortran_env, only: int8
use iterator_module, only: user_type, user_collection_type, user_iterator_type, iterator_type
type(user_type) :: user1, user2, user
type(user_collection_type) :: user_collection
! TODO:
class(iterator_type), allocatable :: iterator
user1 = user_type(name="A", age=30_int8)
user2 = user_type(name="B", age=20_int8)
user_collection = user_collection_type(users=[user1, user2])
!> Specific iterator
allocate (user_iterator_type :: iterator)
iterator = user_collection%create_iterator()
do while (iterator%has_next())
user = iterator%get_next()
print "(3A,I3)", "User is ", user%name, ", age is ", user%age
end do
deallocate (iterator)
end program iterator_main
!> Results shall be:
! User is A, age is 30
! User is B, age is 20
观察者模式
正文：https://refactoringguru.cn/design-patterns/observer
Go代码：https://refactoringguru.cn/design-patterns/observer/go/example
!> Reference: https://refactoring.guru/design-patterns/observer/go/example
module observer_pattern
implicit none
private
public :: item_type, customer_type, new_item
!> Abstract classes
type, abstract :: subject_type
contains
procedure(register_procedure), deferred :: register
procedure(deregister_procedure), deferred :: deregister
procedure(notify_all_procedure), deferred :: notify_all
end type subject_type
type, abstract :: observer_type
contains
procedure(update_procedure), deferred :: update
procedure(get_ID_procedure), deferred :: get_ID
end type observer_type
!> We cannot directly use `class(observer), allocatable :: o_list(:)`
!> instead of `type(node), allocatable :: o_list(:)`.
type node_type
class(observer_type), allocatable :: o
end type node_type
abstract interface
subroutine register_procedure(self, o)
import subject_type, observer_type
class(subject_type), intent(inout) :: self
class(observer_type), intent(inout) :: o
end subroutine register_procedure
subroutine deregister_procedure(self, o)
import subject_type, observer_type
class(subject_type), intent(inout) :: self
class(observer_type), intent(inout) :: o
end subroutine deregister_procedure
subroutine notify_all_procedure(self)
import subject_type
class(subject_type), intent(inout) :: self
end subroutine notify_all_procedure
subroutine update_procedure(self, s)
import observer_type
class(observer_type), intent(inout) :: self
character(len=*), intent(inout) :: s
end subroutine update_procedure
function get_ID_procedure(self) result(result)
import observer_type
class(observer_type), intent(inout) :: self
character(len=:), allocatable :: result
end function get_ID_procedure
end interface
!> Specific objects
type, extends(subject_type) :: item_type
type(node_type), allocatable :: o_list(:)
character(len=:), allocatable :: name
logical :: in_stock
contains
procedure :: update_availability
procedure :: register
procedure :: deregister
procedure :: notify_all
end type item_type
type, extends(observer_type) :: customer_type
character(len=:), allocatable :: ID
contains
procedure :: update
procedure :: get_ID
end type customer_type
contains
!> Constructor of `item`.
function new_item(name) result(i)
character(*), intent(in) :: name
type(item_type) :: i
i%name = name
end function new_item
!> Remove a object from the subscription array.
function remove_from_slice(o_list, o_to_remove) result(result)
type(node_type), intent(inout) :: o_list(:)
class(observer_type), intent(inout) :: o_to_remove
type(node_type), allocatable :: result(:)
character(len=:), allocatable :: id
integer :: i, j
i = size(o_list)
id = o_to_remove%get_ID()
do j = 1, i
if (o_list(j)%o%get_ID() == id) then
allocate (result(i - 1), source=[o_list(:j - 1), o_list(j + 1:)])
return
end if
end do
result = o_list
end function remove_from_slice
!> Append a object to the subscription array.
function append_slice(o_list, o_to_append) result(result)
type(node_type), intent(inout), allocatable :: o_list(:)
class(observer_type), intent(inout) :: o_to_append
type(node_type), allocatable :: result(:)
integer :: i
if (.not. allocated(o_list)) then
allocate (result(1))
allocate (result(1)%o, source=o_to_append)
else
i = size(o_list)
allocate (result(i + 1))
result(1:i) = o_list
allocate (result(i + 1)%o, source=o_to_append)
end if
end function append_slice
subroutine update_availability(self)
class(item_type), intent(inout) :: self
print *, "> Item "//self%name//" 👔 is now in stock."
self%in_stock = .true.
call self%notify_all()
end subroutine update_availability
subroutine register(self, o)
class(item_type), intent(inout) :: self
class(observer_type), intent(inout) :: o
self%o_list = append_slice(self%o_list, o)
end subroutine register
subroutine deregister(self, o)
class(item_type), intent(inout) :: self
class(observer_type), intent(inout) :: o
self%o_list = remove_from_slice(self%o_list, o)
end subroutine deregister
subroutine notify_all(self)
class(item_type), intent(inout) :: self
integer :: i
do i = 1, size(self%o_list)
call self%o_list(i)%o%update(self%name)
end do
end subroutine notify_all
subroutine update(self, s)
class(customer_type), intent(inout) :: self
character(len=*), intent(inout) :: s
print *, "Sending email to customer "//self%ID//" 📨 for item "//s//"."
end subroutine update
function get_ID(self) result(result)
class(customer_type), intent(inout) :: self
character(len=:), allocatable :: result
result = self%ID
end function get_ID
end module observer_pattern
!> Reference: https://refactoring.guru/design-patterns/observer/go/example
program test_observer
use observer_pattern, only: item_type, customer_type, new_item
type(item_type) :: shirt_item
type(customer_type) :: observer_first, observer_second, observer_third
!> A shirt item
shirt_item = new_item("A Shirt")
!> Some customers
observer_first = customer_type(ID="abc@gmail.com")
observer_second = customer_type(ID="def@gmail.com")
observer_third = customer_type(ID="xyz@foxmail.com")
!> Scene 1
call shirt_item%register(observer_first)
call shirt_item%register(observer_second)
call shirt_item%update_availability()
!> Scene 2
call shirt_item%deregister(observer_first)
call shirt_item%register(observer_third)
call shirt_item%update_availability()
end program test_observer
!> Results shall be:
! > Item A Shirt 👔 is now in stock.
! Sending email to customer abc@gmail.com 📨 for item A Shirt.
! Sending email to customer def@gmail.com 📨 for item A Shirt.
! > Item A Shirt 👔 is now in stock.
! Sending email to customer def@gmail.com 📨 for item A Shirt.
! Sending email to customer xyz@foxmail.com 📨 for item A Shirt.
中介者模式
正文：https://refactoringguru.cn/design-patterns/mediator
Go代码：https://refactoringguru.cn/design-patterns/mediator/go/example
module mediator_module
implicit none
private
public :: station_manager_type, passenger_train_type, freight_train_type
type, abstract :: train_type
contains
procedure(train_type_arrive), deferred :: arrive
procedure(train_type_depart), deferred :: depart
procedure(train_type_permit_arrival), deferred :: permit_arrival
end type train_type
type, abstract :: mediator_t
contains
procedure(mediator_type_can_arrive), deferred :: can_arrive
procedure(mediator_type_notify_about_departure), deferred :: notify_about_departure
end type mediator_t
abstract interface
subroutine train_type_arrive(self)
import train_type
class(train_type), intent(inout) :: self
end subroutine train_type_arrive
subroutine train_type_depart(self)
import train_type
class(train_type), intent(inout) :: self
end subroutine train_type_depart
subroutine train_type_permit_arrival(self)
import train_type
class(train_type), intent(inout) :: self
end subroutine train_type_permit_arrival
logical function mediator_type_can_arrive(self, train) result(can)
import mediator_t, train_type
class(mediator_t), intent(inout) :: self
class(train_type), intent(in), target :: train
end function mediator_type_can_arrive
subroutine mediator_type_notify_about_departure(self)
import mediator_t
class(mediator_t), intent(inout) :: self
end subroutine mediator_type_notify_about_departure
end interface
type, extends(train_type) :: passenger_train_type
class(mediator_t), pointer :: mediator
contains
procedure :: arrive => passenger_train_type_arrive
procedure :: depart => passenger_train_type_depart
procedure :: permit_arrival => passenger_train_type_permit_arrival
end type passenger_train_type
type, extends(train_type) :: freight_train_type
class(mediator_t), pointer :: mediator
contains
procedure :: arrive => freight_train_type_arrive
procedure :: depart => freight_train_type_depart
procedure :: permit_arrival => freight_train_type_permit_arrival
end type freight_train_type
type node_t
class(train_type), pointer :: train
end type node_t
type, extends(mediator_t) :: station_manager_type
logical :: is_platform_free = .true.
type(node_t), allocatable :: list(:)
contains
procedure :: can_arrive => station_manager_type_can_arrive
procedure :: notify_about_departure => station_manager_type_notify_about_departure
end type station_manager_type
contains
subroutine passenger_train_type_arrive(self)
class(passenger_train_type), intent(inout) :: self
if (.not. self%mediator%can_arrive(self)) then
print *, "Passenger train: arrival blocked, waiting"
return
end if
print *, "Passenger train: arrived"
end subroutine passenger_train_type_arrive
subroutine passenger_train_type_depart(self)
class(passenger_train_type), intent(inout) :: self
print *, "Passenger train: leaving"
call self%mediator%notify_about_departure()
end subroutine passenger_train_type_depart
subroutine passenger_train_type_permit_arrival(self)
class(passenger_train_type), intent(inout) :: self
print *, "Passenger train: arrival permitted, arriving"
call self%arrive()
end subroutine passenger_train_type_permit_arrival
subroutine freight_train_type_arrive(self)
class(freight_train_type), intent(inout) :: self
if (.not. self%mediator%can_arrive(self)) then
print *, "Freight train: arrival blocked, waiting"
return
end if
print *, "Freight train: arrived"
end subroutine freight_train_type_arrive
subroutine freight_train_type_depart(self)
class(freight_train_type), intent(inout) :: self
print *, "freight train: leaving"
call self%mediator%notify_about_departure()
end subroutine freight_train_type_depart
subroutine freight_train_type_permit_arrival(self)
class(freight_train_type), intent(inout) :: self
print *, "Freight train: arrival permitted, arriving"
call self%arrive()
end subroutine freight_train_type_permit_arrival
logical function station_manager_type_can_arrive(self, train) result(can)
class(station_manager_type), intent(inout) :: self
class(train_type), intent(in), target :: train
if (self%is_platform_free) then
self%is_platform_free = .false.
can = .true.
return
end if
self%list = [self%list, node_t(train)]
can = .false.
end function station_manager_type_can_arrive
subroutine station_manager_type_notify_about_departure(self)
class(station_manager_type), intent(inout) :: self
class(train_type), pointer :: train
if (.not. self%is_platform_free) then
self%is_platform_free = .true.
end if
if (size(self%list) > 0) then
train => self%list(1)%train
!> 内存泄露
self%list = self%list(2:)
call train%permit_arrival()
end if
end subroutine station_manager_type_notify_about_departure
end module mediator_module
program mediator_main
use mediator_module, only: station_manager_type,passenger_train_type,freight_train_type
implicit none
type(station_manager_type), target :: station_manager
type(passenger_train_type) :: passenger_train
type(freight_train_type) :: freight_train
allocate(station_manager%list(0))
passenger_train%mediator => station_manager
freight_train%mediator => station_manager
call passenger_train%arrive()
call freight_train%arrive()
call passenger_train%depart()
end program mediator_main
!> Results shall be:
! Passenger train: arrived
! Freight train: arrival blocked, waiting
! Passenger train: leaving
! Freight train: arrival permitted, arriving
! Freight train: arrived
备忘录模式
正文：https://refactoringguru.cn/design-patterns/memento
Go代码：https://refactoringguru.cn/design-patterns/memento/go/example
module memento_module
implicit none
private
public :: caretaker_type, originator_type
type originator_type
character(:), allocatable :: state
contains
procedure :: create_memento => originator_t_create_memento
procedure :: restore_memento => originator_t_restore_memento
procedure :: set_state => originator_t_set_state
procedure :: get_state => originator_t_get_state
end type originator_type
type memento_type
character(:), allocatable :: state
end type memento_type
type caretaker_type
type(memento_type), allocatable :: memento(:)
contains
procedure :: add_memento => caretaker_t_add_memento
procedure :: get_memento => caretaker_t_get_memento
end type caretaker_type
contains
function originator_t_create_memento(self) result(memento)
class(originator_type), intent(inout) :: self
type(memento_type) :: memento
memento%state = self%state
end function originator_t_create_memento
subroutine originator_t_restore_memento(self, memento)
class(originator_type), intent(inout) :: self
type(memento_type), intent(in) :: memento
self%state = memento%state
end subroutine originator_t_restore_memento
subroutine originator_t_set_state(self, state)
class(originator_type), intent(inout) :: self
character(*), intent(in) :: state
self%state = state
end subroutine originator_t_set_state
function originator_t_get_state(self) result(state)
class(originator_type), intent(inout) :: self
character(:), allocatable :: state
state = self%state
end function originator_t_get_state
subroutine caretaker_t_add_memento(self, memento)
class(caretaker_type), intent(inout) :: self
type(memento_type), intent(in) :: memento
self%memento = [self%memento, memento]
end subroutine caretaker_t_add_memento
function caretaker_t_get_memento(self, index) result(memento)
class(caretaker_type), intent(inout) :: self
integer, intent(in) :: index
type(memento_type) :: memento
memento = self%memento(index)
end function caretaker_t_get_memento
end module memento_module
program memento_main
use memento_module, only: caretaker_type, originator_type
type(caretaker_type) :: caretaker
type(originator_type) :: originator
allocate (caretaker%memento(0))
originator%state = "A"
print *, "Originator state: ", originator%get_state()
call caretaker%add_memento(originator%create_memento())
call originator%set_state("B")
print *, "Originator current state: ", originator%get_state()
call caretaker%add_memento(originator%create_memento())
call originator%set_state("C")
print *, "Originator current state: ", originator%get_state()
call caretaker%add_memento(originator%create_memento())
call originator%restore_memento(caretaker%get_memento(2))
print *, "Restored to state: ", originator%get_state()
call originator%restore_memento(caretaker%get_memento(1))
print *, "Restored to state: ", originator%get_state()
end program memento_main
!> Results shall be:
! Originator state: A
! Originator current state: B
! Originator current state: C
! Restored to state: B
! Restored to state: A
状态模式
正文：https://refactoringguru.cn/design-patterns/state
Fortran代码：https://my.oschina.net/zuozhihua/blog/5150176
module state_module
implicit none
private
public :: person_type
type :: hungry_state_type
logical :: state
contains
procedure :: hungry => hungry_state_t_hungry
procedure :: no_hungry => hungry_state_t_no_hungry
end type hungry_state_type
type :: person_type
type(hungry_state_type) :: hungry_state
contains
procedure :: eat => person_t_eat
procedure :: work => person_t_work
end type
contains
subroutine person_t_eat(self)
class(person_type), intent(inout) :: self
if (self%hungry_state%state) then
print *, "Eatting.."
!!// 改变状态
call self%hungry_state%no_hungry
else
print *, "Already baole!!"
end if
end subroutine person_t_eat
subroutine person_t_work(self)
class(person_type), intent(inout) :: self
if (self%hungry_state%state) then
print *, "I am hungry, no work!!"
else
print *, "Ok, let us do work.."
call self%hungry_state%hungry
end if
end subroutine person_t_work
subroutine hungry_state_t_hungry(self)
class(hungry_state_type), intent(inout) :: self
self%state = .true.
end subroutine hungry_state_t_hungry
subroutine hungry_state_t_no_hungry(self)
class(hungry_state_type), intent(inout) :: self
self%state = .false.
end subroutine hungry_state_t_no_hungry
end module state_module
program state_main
use state_module, only: person_type
implicit none
type(person_type) :: person
call person%hungry_state%no_hungry
call person%work
call person%work
call person%eat
call person%eat
end program state_main
!> Results shall be:
! Ok, let us do work..
! I am hungry, no work!!
! Eatting..
! Already baole!!
策略模式
正文：https://refactoringguru.cn/design-patterns/strategy
Go代码：https://refactoringguru.cn/design-patterns/strategy/go/example
策略模式能将调用策略判断的过程抽象出来，并提前部署策略。
module strategy_module
implicit none
private
public :: add_type, sub_type, calculator_type
type, abstract :: strategy_type
contains
procedure(strategy_type_calc), deferred :: calc
end type strategy_type
abstract interface
integer function strategy_type_calc(self, a, b) result(c)
import strategy_type
class(strategy_type), intent(inout) :: self
integer, intent(in) :: a, b
end function strategy_type_calc
end interface
type, extends(strategy_type) :: add_type
contains
procedure :: calc => add_type_calc
end type add_type
type, extends(strategy_type) :: sub_type
contains
procedure :: calc => sub_type_calc
end type sub_type
type calculator_type
class(strategy_type), pointer :: strategy
contains
procedure :: set_strategy => calculator_type_set_strategy
procedure :: get_result => calculator_type_get_result
end type calculator_type
contains
integer function add_type_calc(self, a, b) result(c)
class(add_type), intent(inout) :: self
integer, intent(in) :: a, b
c = a + b
end function add_type_calc
integer function sub_type_calc(self, a, b) result(c)
class(sub_type), intent(inout) :: self
integer, intent(in) :: a, b
c = a - b
end function sub_type_calc
subroutine calculator_type_set_strategy(self, strategy)
class(calculator_type), intent(inout) :: self
class(strategy_type), intent(in), target :: strategy
self%strategy => strategy
end subroutine calculator_type_set_strategy
integer function calculator_type_get_result(self, a, b) result(c)
class(calculator_type), intent(inout) :: self
integer, intent(in) :: a, b
c = self%strategy%calc(a, b)
end function calculator_type_get_result
end module strategy_module
program strategy_main
use strategy_module, only: add_type, sub_type, calculator_type
implicit none
type(add_type) :: add
type(sub_type) :: sub
type(calculator_type) :: calculator
call calculator%set_strategy(add)
print *, "Add:", calculator%strategy%calc(1, 1)
call calculator%set_strategy(sub)
print *, "Sub:", calculator%strategy%calc(1, 1)
end program strategy_main
!> Results shall be:
! Add: 2
! Sub: 0
模板方法模式
正文：https://refactoringguru.cn/design-patterns/template-method
Go代码：https://refactoringguru.cn/design-patterns/template-method/go/example
module template_method_module
implicit none
private
public :: otp_type, sms_type, email_type
type, abstract :: iopt_type
contains
procedure(iopt_type_gen_random_opt), deferred :: gen_random_opt
procedure(iopt_type_save_opt_cache), deferred :: save_opt_cache
procedure(iopt_type_get_message), deferred :: get_message
procedure(iopt_type_send_notification), deferred :: send_notification
procedure(iopt_type_publish_metric), deferred :: publish_metric
end type iopt_type
abstract interface
function iopt_type_gen_random_opt(self, len) result(random_opt)
import iopt_type
class(iopt_type), intent(inout) :: self
integer, intent(in) :: len
character(:), allocatable :: random_opt
end function iopt_type_gen_random_opt
subroutine iopt_type_save_opt_cache(self, otp)
import iopt_type
class(iopt_type), intent(inout) :: self
character(*), intent(inout) :: otp
end subroutine iopt_type_save_opt_cache
function iopt_type_get_message(self, otp) result(msg)
import iopt_type
class(iopt_type), intent(inout) :: self
character(*), intent(inout) :: otp
character(:), allocatable :: msg
end function iopt_type_get_message
subroutine iopt_type_send_notification(self, msg)
import iopt_type
class(iopt_type), intent(inout) :: self
character(*), intent(inout) :: msg
end subroutine iopt_type_send_notification
subroutine iopt_type_publish_metric(self)
import iopt_type
class(iopt_type), intent(inout) :: self
end subroutine iopt_type_publish_metric
end interface
! - - - - - - - - - - - - -
type otp_type
class(iopt_type), pointer :: iopt
contains
procedure :: gen_and_send_otp => otp_type_gen_and_send_otp
end type otp_type
type, extends(iopt_type) :: sms_type
contains
procedure :: gen_random_opt => sms_type_gen_random_opt
procedure :: save_opt_cache => sms_type_save_opt_cache
procedure :: get_message => sms_type_get_message
procedure :: send_notification => sms_type_send_notification
procedure :: publish_metric => sms_type_publish_metric
end type sms_type
type, extends(iopt_type) :: email_type
contains
procedure :: gen_random_opt => email_type_gen_random_opt
procedure :: save_opt_cache => email_type_save_opt_cache
procedure :: get_message => email_type_get_message
procedure :: send_notification => email_type_send_notification
procedure :: publish_metric => email_type_publish_metric
end type email_type
contains
subroutine otp_type_gen_and_send_otp(self, otp_length)
class(otp_type), intent(inout) :: self
integer, intent(in) :: otp_length
character(:), allocatable :: otp
character(:), allocatable :: msg
otp = self%iopt%gen_random_opt(otp_length)
call self%iopt%save_opt_cache(otp)
msg = self%iopt%get_message(otp)
call self%iopt%send_notification(msg)
call self%iopt%publish_metric()
end subroutine otp_type_gen_and_send_otp
! - - - - - - - - - -
function sms_type_gen_random_opt(self, len) result(random_opt)
class(sms_type), intent(inout) :: self
integer, intent(in) :: len
character(:), allocatable :: random_opt
random_opt = "1234"
print *, "SMS: generating random otp ", random_opt
end function sms_type_gen_random_opt
subroutine sms_type_save_opt_cache(self, otp)
class(sms_type), intent(inout) :: self
character(*), intent(inout) :: otp
print *, "SMS: saving otp: ", otp, " to cache"
end subroutine sms_type_save_opt_cache
function sms_type_get_message(self, otp) result(msg)
class(sms_type), intent(inout) :: self
character(*), intent(inout) :: otp
character(:), allocatable :: msg
msg = "SMS OTP for login is "//otp
end function sms_type_get_message
subroutine sms_type_send_notification(self, msg)
class(sms_type), intent(inout) :: self
character(*), intent(inout) :: msg
print *, "SMS: sending sms: "//msg
end subroutine sms_type_send_notification
subroutine sms_type_publish_metric(self)
class(sms_type), intent(inout) :: self
print *, "SMS: publishing metric"
end subroutine sms_type_publish_metric
! - - - - - - - - - -
function email_type_gen_random_opt(self, len) result(random_opt)
class(email_type), intent(inout) :: self
integer, intent(in) :: len
character(:), allocatable :: random_opt
random_opt = "1234"
print *, "EMAIL: generating random otp ", random_opt
end function email_type_gen_random_opt
subroutine email_type_save_opt_cache(self, otp)
class(email_type), intent(inout) :: self
character(*), intent(inout) :: otp
print *, "EMAIL: saving otp: ", otp, " to cache"
end subroutine email_type_save_opt_cache
function email_type_get_message(self, otp) result(msg)
class(email_type), intent(inout) :: self
character(*), intent(inout) :: otp
character(:), allocatable :: msg
msg = "EMAIL OTP for login is "//otp
end function email_type_get_message
subroutine email_type_send_notification(self, msg)
class(email_type), intent(inout) :: self
character(*), intent(inout) :: msg
print *, "EMAIL: sending email: "//msg
end subroutine email_type_send_notification
subroutine email_type_publish_metric(self)
class(email_type), intent(inout) :: self
print *, "EMAIL: publishing metric"
end subroutine email_type_publish_metric
end module template_method_module
program template_method_main
use template_method_module, only: otp_type, sms_type, email_type
type(otp_type) :: otp
type(sms_type), target :: sms_otp
type(email_type), target :: email_otp
sms_otp = sms_type()
otp%iopt => sms_otp
call otp%gen_and_send_otp(4)
write (*, *)
email_otp = email_type()
otp%iopt => email_otp
call otp%gen_and_send_otp(4)
end program template_method_main
!> Results shall be:
! SMS: generating random otp 1234
! SMS: saving otp: 1234 to cache
! SMS: sending sms: SMS OTP for login is 1234
! SMS: publishing metric
!
! EMAIL: generating random otp 1234
! EMAIL: saving otp: 1234 to cache
! EMAIL: sending email: EMAIL OTP for login is 1234
! EMAIL: publishing metric
访问者模式
正文：https://refactoringguru.cn/design-patterns/visitor
Go代码：https://refactoringguru.cn/design-patterns/visitor/go/example
!> Reference: https://refactoring.guru/design-patterns/visitor/go/example
module visitor_pattern
implicit none
private
public :: square_type, circle_type, rectangle_type, area_calculator_type, middle_coordinates_type
!> Two abstract classes
type, abstract :: shape
contains
procedure(get_type_procedure), deferred :: get_type
procedure(accept_procedure), deferred :: accept
end type shape
type, abstract :: visitor
contains
procedure(visit_procedure), deferred :: visit
end type visitor
abstract interface
function get_type_procedure(self) result(result)
import shape
class(shape), intent(inout) :: self
character(:), allocatable :: result
end function get_type_procedure
subroutine accept_procedure(self, v)
import shape, visitor
class(shape), intent(inout) :: self
class(visitor), intent(inout) :: v
end subroutine accept_procedure
subroutine visit_procedure(self, s)
import visitor, shape
class(visitor), intent(inout) :: self
class(shape), intent(inout) :: s
end subroutine visit_procedure
end interface
!> Specific shapes
type, extends(shape) :: square_type
integer :: side
contains
procedure :: get_type => square_get_type
procedure :: accept => square_accept
end type square_type
type, extends(shape) :: circle_type
integer :: radius
contains
procedure :: get_type => circle_get_type
procedure :: accept => circle_accept
end type circle_type
type, extends(shape) :: rectangle_type
integer :: l
integer :: b
contains
procedure :: get_type => rectangle_get_type
procedure :: accept => rectangle_accept
end type rectangle_type
!> Specific visitors
type, extends(visitor) :: area_calculator_type
integer :: area
contains
procedure :: visit => area_calculator_visit
end type area_calculator_type
type, extends(visitor) :: middle_coordinates_type
integer :: x, y
contains
procedure :: visit => middle_coordinates_visit
end type middle_coordinates_type
contains
function square_get_type(self) result(result)
class(square_type), intent(inout) :: self
character(:), allocatable :: result
result = "Square"
end function square_get_type
function circle_get_type(self) result(result)
class(circle_type), intent(inout) :: self
character(:), allocatable :: result
result = "Circle"
end function circle_get_type
function rectangle_get_type(self) result(result)
class(rectangle_type), intent(inout) :: self
character(:), allocatable :: result
result = "Rectangle"
end function rectangle_get_type
subroutine square_accept(self, v)
class(square_type), intent(inout) :: self
class(visitor), intent(inout) :: v
call v%visit(self)
end subroutine square_accept
subroutine circle_accept(self, v)
class(circle_type), intent(inout) :: self
class(visitor), intent(inout) :: v
call v%visit(self)
end subroutine circle_accept
subroutine rectangle_accept(self, v)
class(rectangle_type), intent(inout) :: self
class(visitor), intent(inout) :: v
call v%visit(self)
end subroutine rectangle_accept
subroutine area_calculator_visit(self, s)
class(area_calculator_type), intent(inout) :: self
class(shape), intent(inout) :: s
select type (s)
type is (square_type)
print *, "Calculating area for square.🔥"
type is (circle_type)
print *, "Calculating area for circle.🔥"
type is (rectangle_type)
print *, "Calculating area for rectangle.🔥"
end select
end subroutine area_calculator_visit
subroutine middle_coordinates_visit(self, s)
class(middle_coordinates_type), intent(inout) :: self
class(shape), intent(inout) :: s
select type (s)
type is (square_type)
print *, "Calculating middle point coordinates for square.💠"
type is (circle_type)
print *, "Calculating middle point coordinates for circle.💠"
type is (rectangle_type)
print *, "Calculating middle point coordinates for rectangle.💠"
end select
end subroutine middle_coordinates_visit
end module visitor_pattern
!> Reference: https://refactoring.guru/design-patterns/visitor/go/example
program test_visitor
use visitor_pattern, only: square_type, circle_type, rectangle_type, area_calculator_type, middle_coordinates_type
type(square_type) :: s = square_type(side=2)
type(circle_type) :: c = circle_type(radius=3)
type(rectangle_type) :: r = rectangle_type(l=2, b=3)
type(area_calculator_type) :: a
type(middle_coordinates_type) :: m
!> area_calculator visiting shapes
call s%accept(a)
call c%accept(a)
call r%accept(a)
!> middle_coordinates visiting shapes
call s%accept(m)
call c%accept(m)
call r%accept(m)
!> Getting type of shape
print *, s%get_type()
print *, c%get_type()
print *, r%get_type()
end program test_visitor
!> Results shall be:
! Calculating area for square.🔥
! Calculating area for circle.🔥
! Calculating area for rectangle.🔥
! Calculating middle point coordinates for square.💠
! Calculating middle point coordinates for circle.💠
! Calculating middle point coordinates for rectangle.💠
! Square
! Circle
! Rectangle
模型与算法
这篇番外，来自室友的一个问题，他在与数学学院的同学合作时，他认为模型与算法差不多是一个东西，但数学学院的同学不认同。
在编程的世界里，主要由函数、数据组成。我们通常将函数称为方法，面向对象思想中，一个对象由若干个数据和方法组成。
当我们要建模时，面向对象往往是一个有效的思路，所以，模型是单个或者多个对象组成的一个数据实体，其核心是模型内部对象间的信息传递，形成相应的模型总体功能。
这样理解的话，算法则更多是方法（函数）而非对象的集合，算法可以是单个或者多个函数的方法实体。但这也不尽然，算法中可以辅助面向对象的建模特性，但算法更注重形成的方法总体功能，形成API，被调用。
此外，还有模式（或者设计模式），即本书的重点，它是对特点场景、模型、算法等实体，事先被记录下来，方便后人按图索骥，是母型图纸，供你视实际情况而定。