├── .github └── workflows │ ├── fpm.yml │ └── mdbook.yml ├── .gitignore ├── LICENSE ├── README.md ├── doc ├── book.toml ├── src │ ├── Introduction.md │ ├── README.md │ ├── SUMMARY.md │ ├── behavioral │ │ ├── chain-of-responsibility.md │ │ ├── command.md │ │ ├── iterator.md │ │ ├── mediator.md │ │ ├── memento.md │ │ ├── observer.md │ │ ├── state.md │ │ ├── strategy.md │ │ ├── template-method.md │ │ └── visitor.md │ ├── creational │ │ ├── abstract-factory.md │ │ ├── builder.md │ │ ├── factory.md │ │ ├── prototype.md │ │ └── singleton.md │ ├── others │ │ └── model-and-algorithm.md │ └── structural │ │ ├── adapter.md │ │ ├── bridge.md │ │ ├── cache.md │ │ ├── composite.md │ │ ├── facade.md │ │ ├── proxy.md │ │ └── wrapper.md └── theme │ └── highlight.js ├── fpm.toml └── src ├── behavioral ├── chain-of-responsibility │ ├── CoR_main.f90 │ └── CoR_module.f90 ├── command │ ├── command_main.f90 │ └── command_module.f90 ├── iterator │ ├── iterator_main.f90 │ └── iterator_module.f90 ├── mediator │ ├── mediator_main.f90 │ └── mediator_module.f90 ├── memento │ ├── memento_main.f90 │ └── memento_module.f90 ├── observer │ ├── observer_main.f90 │ └── observer_module.f90 ├── state │ ├── state_main.f90 │ └── state_module.f90 ├── strategy │ ├── extends │ │ └── strategy_main.f90 │ ├── strategy_main.f90 │ └── strategy_module.f90 ├── template-method │ ├── template_method_main.f90 │ └── template_method_module.f90 └── visitor │ ├── visitor_main.f90 │ └── visitor_module.f90 ├── creational ├── abstract-factory │ ├── abstract_factory_main.f90 │ └── abstract_factory_module.f90 ├── builder │ ├── builder_main.f90 │ └── builder_module.f90 ├── factory │ ├── factory_main.f90 │ └── factory_module.f90 ├── prototype │ ├── prototype_main.f90 │ └── prototype_module.f90 └── singleton │ ├── singleton_main.f90 │ └── singleton_module.f90 ├── others ├── interface-limit │ ├── interface_limit_main.f90 │ └── interface_limit_module.f90 └── interface-specific │ ├── interface_specific_main.f90 │ └── interface_specific_module.f90 └── structural ├── adapter ├── adapter_main.f90 └── adapter_module.f90 ├── bridge ├── bridge_main.f90 └── bridge_module.f90 ├── cache ├── cache_main.f90 └── cache_module.f90 ├── composite ├── composite_main.f90 └── composite_module.f90 ├── facade ├── facade_main.f90 └── facade_module.f90 ├── proxy ├── proxy_main.f90 └── proxy_module.f90 └── wrapper ├── wrapper_main.f90 └── wrapper_module.f90 /.github/workflows/fpm.yml: -------------------------------------------------------------------------------- 1 | name: fpm 2 | 3 | on: 4 | push: 5 | paths: 6 | - ".github/workflows/fpm.yml" 7 | - "src/**.f90" 8 | - "fpm.toml" 9 | 10 | pull_request: 11 | branches: 12 | - main 13 | paths: 14 | - ".github/workflows/fpm.yml" 15 | - "src/**.f90" 16 | - "fpm.toml" 17 | 18 | jobs: 19 | build: 20 | runs-on: ${{ matrix.os }} 21 | strategy: 22 | fail-fast: false 23 | matrix: 24 | os: [ubuntu-latest] 25 | gcc_v: [11] # Version of GFortran we want to use. 26 | include: 27 | - os: ubuntu-latest 28 | os-arch: linux-x86_64 29 | 30 | env: 31 | FC: gfortran 32 | GCC_V: ${{ matrix.gcc_v }} 33 | 34 | steps: 35 | - name: Checkout code 36 | uses: actions/checkout@v2 37 | 38 | - name: Install GFortran Linux 39 | if: contains(matrix.os, 'ubuntu') 40 | run: | 41 | sudo update-alternatives --install /usr/bin/gcc gcc /usr/bin/gcc-${GCC_V} 100 \ 42 | --slave /usr/bin/gfortran gfortran /usr/bin/gfortran-${GCC_V} \ 43 | --slave /usr/bin/gcov gcov /usr/bin/gcov-${GCC_V} 44 | 45 | - name: Install fpm 46 | uses: fortran-lang/setup-fpm@v5 47 | with: 48 | fpm-version: 'v0.9.0' 49 | 50 | - name: Build & Test 51 | run: | 52 | gfortran --version 53 | fpm build 54 | fpm test -------------------------------------------------------------------------------- /.github/workflows/mdbook.yml: -------------------------------------------------------------------------------- 1 | name: mdbook 2 | on: 3 | push: 4 | paths: 5 | - "doc/src/**.md" 6 | - "doc/book.toml" 7 | - "doc/theme/**.js" 8 | - "src/**.f90" 9 | 10 | pull_request: 11 | branches: 12 | - main 13 | paths: 14 | - "doc/src/**.md" 15 | - "doc/book.toml" 16 | - "doc/theme/**.js" 17 | - "src/**.f90" 18 | 19 | jobs: 20 | pages: 21 | name: GitHub Pages 22 | runs-on: ubuntu-latest 23 | steps: 24 | - uses: actions/checkout@v2 25 | 26 | - name: Setup mdBook 📔 27 | uses: peaceiris/actions-mdbook@v1 28 | with: 29 | mdbook-version: '0.4.10' 30 | # mdbook-version: 'latest' 31 | 32 | - run: cd doc && mdbook build 33 | 34 | - name: Deploy 🚀 35 | uses: peaceiris/actions-gh-pages@v3 36 | if: github.event_name == 'push' && github.repository == 'zoziha/Fortran-Design-Patterns' && ${{ github.ref == 'refs/heads/main' }} 37 | with: 38 | github_token: ${{ secrets.GITHUB_TOKEN }} 39 | publish_dir: ./doc/book -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .vscode/* 2 | build/* 3 | doc/book/* -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2021~2024, ZUO Zhihua 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Fortran的23种设计模式 2 | 3 | [![BSD-3](https://img.shields.io/github/license/zoziha/Fortran-Design-Patterns?color=pink)](LICENSE) 4 | [![fpm](https://github.com/zoziha/Fortran-Design-Patterns/workflows/fpm/badge.svg)](https://github.com/zoziha/Fortran-Design-Patterns/actions) 5 | [![mdbook](https://github.com/zoziha/Fortran-Design-Patterns/workflows/mdbook/badge.svg)](https://github.com/zoziha/Fortran-Design-Patterns/actions) 6 | 7 | 《Fortran的23种设计模式》是一份Fortran面向对象编程中文实用教程。 8 | 9 | |项目|描述| 10 | |:-:|:-:| 11 | |版本：|0.3.0| 12 | |作者：|ZUO Zhihua| 13 | |网页：|https://zoziha.github.io/Fortran-Design-Patterns/| 14 | |版权：|Copyright (c) 2021~2024 zoziha| 15 | 16 | ## 开始 17 | 18 | ### 软件依赖 19 | 20 | - Git 21 | - [fortran-lang/fpm](https://github.com/fortran-lang/fpm) 22 | - [Rust](https://www.rust-lang.org/zh-CN/) 23 | - [mdbook](https://github.com/rust-lang/mdBook) 24 | 25 | ### 获取代码 26 | 27 | ```sh 28 | git clone https://github.com/zoziha/Fortran-Design-Patterns.git 29 | cd Fortran-Design-Patterns 30 | ``` 31 | 32 | ### 使用[fortran-lang/fpm](https://github.com/fortran-lang/fpm)构建代码 33 | 34 | Fortran包管理器（fpm）是Fortran-lang社区驱动、为Fortran生态设计的包管理器和代码构建器。 35 | 你可以通过提供的`fpm.toml`构建代码： 36 | 37 | ```sh 38 | fpm test --list # 获取已提供的设计模式示例 39 | fpm test 40 | ``` 41 | 42 | ### 使用[mdbook](https://github.com/rust-lang/mdBook)构建文档 43 | 44 | mdBook是一个从Markdown文件创建现代在线书籍的实用程序。 45 | 你可以通过提供的`book.toml`文件来构建《Fortran的23种设计模式》。 46 | 47 | ```sh 48 | cd doc && mdbook build 49 | ``` 50 | 51 | ### 链接 52 | 53 | - [设计模式](https://refactoringguru.cn/design-patterns) 54 | - [farhanjk/FortranPatterns](https://github.com/farhanjk/FortranPatterns) -------------------------------------------------------------------------------- /doc/book.toml: -------------------------------------------------------------------------------- 1 | [book] 2 | authors = ["ZUO Zhihua"] 3 | language = "zh" 4 | multilingual = false 5 | src = "src" 6 | title = "Fortran的23种设计模式" 7 | 8 | [output.html] 9 | git-repository-url = "https://github.com/zoziha/Fortran-Design-Patterns/tree/main/" 10 | edit-url-template = "https://github.com/zoziha/Fortran-Design-Patterns/edit/main/doc/{path}" -------------------------------------------------------------------------------- /doc/src/Introduction.md: -------------------------------------------------------------------------------- 1 | # Fortran的23种设计模式 2 | 3 | 视频链接：https://www.bilibili.com/video/BV1wU4y1E7xG?spm_id_from=333.999.0.0 4 | 5 | 设计模式：https://refactoringguru.cn/design-patterns/go 6 | 7 | Fortran三种编程范式：https://zhuanlan.zhihu.com/p/412243161 8 | 9 | 在线编译器：https://godbolt.org/ 10 | 11 | 面向对象：面向对象的**内核是传递信息**，以对象（结构体）为载体，它是建模直观的。 12 | 13 | 设计模式：模式的概念是由克里斯托佛·亚历山大在其著作《建筑模式语言》中首次提出的。**模式可复用**，除非有必要，不必重新思考模式。 14 | 15 | ## 设计模式列表 16 | 17 | |状态|创建型模式|结构型模式|行为模式| 18 | |:-:|:-:|:-:|:-:| 19 | |完成|抽象工厂、生成器、工厂方法、原型、单例。|适配器、桥接、组合、装饰、外观、代理、享元。|责任链、命令、迭代器、观察者、状态、模板方法、备忘录、中介者、访问者、策略。| 20 | 21 | ### 创建型模式 22 | 23 | - [X] 抽象工厂 24 | - [X] 生成器 25 | - [X] 工厂方法 26 | - [X] 原型 27 | - [X] 单例 28 | 29 | ### 结构型模式 30 | 31 | - [X] 适配器 32 | - [X] 桥接 33 | - [X] 组合 34 | - [X] 装饰 35 | - [X] 外观 36 | - [X] 享元 37 | - [X] 代理 38 | 39 | ### 行为模式 40 | 41 | - [X] 责任链 42 | - [X] 命令 43 | - [X] 迭代器 44 | - [X] 中介者 45 | - [X] 备忘录 46 | - [X] 观察者 47 | - [X] 状态 48 | - [X] 策略 49 | - [X] 模板方法 50 | - [X] 访问者 51 | -------------------------------------------------------------------------------- /doc/src/README.md: -------------------------------------------------------------------------------- 1 | {{#include ../../README.md}} 2 | 3 | ## 开源许可证 4 | 5 | {{#include ../../LICENSE}} -------------------------------------------------------------------------------- /doc/src/SUMMARY.md: -------------------------------------------------------------------------------- 1 | # SUMMARY 2 | 3 | - [关于](README.md) 4 | - [Fortran的23种设计模式](Introduction.md) 5 | 6 | --- 7 | 8 | - [抽象工厂模式](creational/abstract-factory.md) 9 | - [生成器模式](creational/builder.md) 10 | - [工厂模式](creational/factory.md) 11 | - [原型模式](creational/prototype.md) 12 | - [单例模式](creational/singleton.md) 13 | 14 | --- 15 | 16 | - [适配器模式](structural/adapter.md) 17 | - [桥接模式](structural/bridge.md) 18 | - [享元模式](structural/cache.md) 19 | - [组合模式](structural/composite.md) 20 | - [外观模式](structural/facade.md) 21 | - [代理模式](structural/proxy.md) 22 | - [装饰模式](structural/wrapper.md) 23 | 24 | --- 25 | 26 | - [责任链模式](behavioral/chain-of-responsibility.md) 27 | - [命令模式](behavioral/command.md) 28 | - [迭代器模式](behavioral/iterator.md) 29 | - [观察者模式](behavioral/observer.md) 30 | - [中介者模式](behavioral/mediator.md) 31 | - [备忘录模式](behavioral/memento.md) 32 | - [状态模式](behavioral/state.md) 33 | - [策略模式](behavioral/strategy.md) 34 | - [模板方法模式](behavioral/template-method.md) 35 | - [访问者模式](behavioral/visitor.md) 36 | 37 | --- 38 | 39 | - [模型与算法](others/model-and-algorithm.md) -------------------------------------------------------------------------------- /doc/src/behavioral/chain-of-responsibility.md: -------------------------------------------------------------------------------- 1 | # 责任链模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/chain-of-responsibility 4 | 5 | Go代码：https://refactoringguru.cn/design-patterns/chain-of-responsibility/go/example 6 | 7 | ## 示例 8 | 9 | 本例子模拟医院的看病缴费的责任链。 10 | 11 | 病人需要进行的大致步骤是： 12 | 13 | 1. 进院，注册信息 14 | 2. 医生检查 15 | 3. 药房给药 16 | 4. 病人缴费，出院 17 | 18 | ```fortran 19 | {{#include ../../../src/behavioral/chain-of-responsibility/CoR_module.f90}} 20 | ``` 21 | 22 | ```fortran 23 | {{#include ../../../src/behavioral/chain-of-responsibility/CoR_main.f90}} 24 | ``` 25 | 26 | ## 评价 27 | 28 | 责任链很像流水线，上一节点处理完进入下一节点。 29 | 30 | 可以应用于科学计算的文件输入检查过程。 -------------------------------------------------------------------------------- /doc/src/behavioral/command.md: -------------------------------------------------------------------------------- 1 | # 命令模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/command 4 | 5 | Go代码：https://refactoringguru.cn/design-patterns/command/go/example 6 | 7 | ```fortran 8 | {{#include ../../../src/behavioral/command/command_module.f90}} 9 | ``` 10 | 11 | ```fortran 12 | {{#include ../../../src/behavioral/command/command_main.f90}} 13 | ``` -------------------------------------------------------------------------------- /doc/src/behavioral/iterator.md: -------------------------------------------------------------------------------- 1 | # 迭代器模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/iterator 4 | 5 | Go代码：https://refactoringguru.cn/design-patterns/iterator/go/example 6 | 7 | ```fortran 8 | {{#include ../../../src/behavioral/iterator/iterator_module.f90}} 9 | ``` 10 | 11 | ```fortran 12 | {{#include ../../../src/behavioral/iterator/iterator_main.f90}} 13 | ``` -------------------------------------------------------------------------------- /doc/src/behavioral/mediator.md: -------------------------------------------------------------------------------- 1 | # 中介者模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/mediator 4 | 5 | Go代码：https://refactoringguru.cn/design-patterns/mediator/go/example 6 | 7 | ```fortran 8 | {{#include ../../../src/behavioral/mediator/mediator_module.f90}} 9 | ``` 10 | 11 | ```fortran 12 | {{#include ../../../src/behavioral/mediator/mediator_main.f90}} 13 | ``` -------------------------------------------------------------------------------- /doc/src/behavioral/memento.md: -------------------------------------------------------------------------------- 1 | # 备忘录模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/memento 4 | 5 | Go代码：https://refactoringguru.cn/design-patterns/memento/go/example 6 | 7 | ```fortran 8 | {{#include ../../../src/behavioral/memento/memento_module.f90}} 9 | ``` 10 | 11 | ```fortran 12 | {{#include ../../../src/behavioral/memento/memento_main.f90}} 13 | ``` -------------------------------------------------------------------------------- /doc/src/behavioral/observer.md: -------------------------------------------------------------------------------- 1 | # 观察者模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/observer 4 | 5 | Go代码：https://refactoringguru.cn/design-patterns/observer/go/example 6 | 7 | ```fortran 8 | {{#include ../../../src/behavioral/observer/observer_module.f90}} 9 | ``` 10 | 11 | ```fortran 12 | {{#include ../../../src/behavioral/observer/observer_main.f90}} 13 | ``` -------------------------------------------------------------------------------- /doc/src/behavioral/state.md: -------------------------------------------------------------------------------- 1 | # 状态模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/state 4 | 5 | Fortran代码：https://my.oschina.net/zuozhihua/blog/5150176 6 | 7 | ```fortran 8 | {{#include ../../../src/behavioral/state/state_module.f90}} 9 | ``` 10 | 11 | ```fortran 12 | {{#include ../../../src/behavioral/state/state_main.f90}} 13 | ``` -------------------------------------------------------------------------------- /doc/src/behavioral/strategy.md: -------------------------------------------------------------------------------- 1 | # 策略模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/strategy 4 | 5 | Go代码：https://refactoringguru.cn/design-patterns/strategy/go/example 6 | 7 | 策略模式能将调用策略判断的过程抽象出来，并提前部署策略。 8 | 9 | ```fortran 10 | {{#include ../../../src/behavioral/strategy/strategy_module.f90}} 11 | ``` 12 | 13 | ```fortran 14 | {{#include ../../../src/behavioral/strategy/strategy_main.f90}} 15 | ``` -------------------------------------------------------------------------------- /doc/src/behavioral/template-method.md: -------------------------------------------------------------------------------- 1 | # 模板方法模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/template-method 4 | 5 | Go代码：https://refactoringguru.cn/design-patterns/template-method/go/example 6 | 7 | ```fortran 8 | {{#include ../../../src/behavioral/template-method/template_method_module.f90}} 9 | ``` 10 | 11 | ```fortran 12 | {{#include ../../../src/behavioral/template-method/template_method_main.f90}} 13 | ``` -------------------------------------------------------------------------------- /doc/src/behavioral/visitor.md: -------------------------------------------------------------------------------- 1 | # 访问者模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/visitor 4 | 5 | Go代码：https://refactoringguru.cn/design-patterns/visitor/go/example 6 | 7 | ```fortran 8 | {{#include ../../../src/behavioral/visitor/visitor_module.f90}} 9 | ``` 10 | 11 | ```fortran 12 | {{#include ../../../src/behavioral/visitor/visitor_main.f90}} 13 | ``` -------------------------------------------------------------------------------- /doc/src/creational/abstract-factory.md: -------------------------------------------------------------------------------- 1 | # 抽象工厂模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/abstract-factory 4 | 5 | Go代码：https://refactoringguru.cn/design-patterns/abstract-factory/go/example 6 | 7 | 点评：显然易见，抽象工厂设计模式缺点之一是，向应用中引入众多的接口和类，代码可能会因此变得更加复杂。 8 | 9 | ```fortran 10 | {{#include ../../../src/creational/abstract-factory/abstract_factory_module.f90}} 11 | ``` 12 | 13 | ```fortran 14 | {{#include ../../../src/creational/abstract-factory/abstract_factory_main.f90}} 15 | ``` 16 | -------------------------------------------------------------------------------- /doc/src/creational/builder.md: -------------------------------------------------------------------------------- 1 | # 生成器模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/builder 4 | 5 | Go代码：https://refactoringguru.cn/design-patterns/builder/go/example 6 | 7 | ```fortran 8 | {{#include ../../../src/creational/builder/builder_module.f90}} 9 | ``` 10 | 11 | ```fortran 12 | {{#include ../../../src/creational/builder/builder_main.f90}} 13 | ``` 14 | 15 | 使用默认结构体构造函数来赋值可分配字符型类型的子元素，在GFortran上出现bug，ifort正常： 16 | 17 | ```fortran 18 | {{#include ../../../src/creational/builder/builder_module.f90:110:116}} 19 | ``` -------------------------------------------------------------------------------- /doc/src/creational/factory.md: -------------------------------------------------------------------------------- 1 | # 工厂模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/factory 4 | 5 | Go代码：https://refactoringguru.cn/design-patterns/factory/go/example 6 | 7 | ```fortran 8 | {{#include ../../../src/creational/factory/factory_module.f90}} 9 | ``` 10 | 11 | ```fortran 12 | {{#include ../../../src/creational/factory/factory_main.f90}} 13 | ``` 14 | -------------------------------------------------------------------------------- /doc/src/creational/prototype.md: -------------------------------------------------------------------------------- 1 | # 原型模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/prototype 4 | 5 | Go代码：https://refactoringguru.cn/design-patterns/prototype/go/example 6 | 7 | ```fortran 8 | {{#include ../../../src/creational/prototype/prototype_module.f90}} 9 | ``` 10 | 11 | ```fortran 12 | {{#include ../../../src/creational/prototype/prototype_main.f90}} 13 | ``` -------------------------------------------------------------------------------- /doc/src/creational/singleton.md: -------------------------------------------------------------------------------- 1 | # 单例模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/singleton 4 | 5 | 6 | ```fortran 7 | {{#include ../../../src/creational/singleton/singleton_module.f90}} 8 | ``` 9 | 10 | ```fortran 11 | {{#include ../../../src/creational/singleton/singleton_main.f90}} 12 | ``` -------------------------------------------------------------------------------- /doc/src/others/model-and-algorithm.md: -------------------------------------------------------------------------------- 1 | # 模型与算法 2 | 3 | 这篇番外，来自室友的一个问题，他在与数学学院的同学合作时，他认为模型与算法差不多是一个东西，但数学学院的同学不认同。 4 | 5 | 在编程的世界里，主要由函数、数据组成。我们通常将函数称为方法，面向对象思想中，一个对象由若干个数据和方法组成。 6 | 7 | 当我们要建模时，面向对象往往是一个有效的思路，所以，模型是单个或者多个对象组成的一个数据实体，其核心是模型内部对象间的信息传递，形成相应的模型总体功能。 8 | 9 | 这样理解的话，算法则更多是方法（函数）而非对象的集合，算法可以是单个或者多个函数的方法实体。但这也不尽然，算法中可以辅助面向对象的建模特性，但算法更注重形成的方法总体功能，形成API，被调用。 10 | 11 | 此外，还有模式（或者设计模式），即本书的重点，它是对特点场景、模型、算法等实体，事先被记录下来，方便后人按图索骥，是母型图纸，供你视实际情况而定。 -------------------------------------------------------------------------------- /doc/src/structural/adapter.md: -------------------------------------------------------------------------------- 1 | # 适配器模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/adapter 4 | 5 | Go代码：https://refactoringguru.cn/design-patterns/adapter/go/example 6 | 7 | ```fortran 8 | {{#include ../../../src/structural/adapter/adapter_module.f90}} 9 | ``` 10 | 11 | ```fortran 12 | {{#include ../../../src/structural/adapter/adapter_main.f90}} 13 | ``` -------------------------------------------------------------------------------- /doc/src/structural/bridge.md: -------------------------------------------------------------------------------- 1 | # 桥接模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/bridge 4 | 5 | Go代码：https://refactoringguru.cn/design-patterns/bridge/go/example 6 | 7 | ```fortran 8 | {{#include ../../../src/structural/bridge/bridge_module.f90}} 9 | ``` 10 | 11 | ```fortran 12 | {{#include ../../../src/structural/bridge/bridge_main.f90}} 13 | ``` -------------------------------------------------------------------------------- /doc/src/structural/cache.md: -------------------------------------------------------------------------------- 1 | # 享元模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/flyweight 4 | 5 | Go代码：https://zhuanlan.zhihu.com/p/343999246 6 | 7 | ```fortran 8 | {{#include ../../../src/structural/cache/cache_module.f90}} 9 | ``` 10 | 11 | ```fortran 12 | {{#include ../../../src/structural/cache/cache_main.f90}} 13 | ``` -------------------------------------------------------------------------------- /doc/src/structural/composite.md: -------------------------------------------------------------------------------- 1 | # 组合模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/composite 4 | 5 | Go代码：https://refactoringguru.cn/design-patterns/composite/go/example 6 | 7 | ```fortran 8 | {{#include ../../../src/structural/composite/composite_module.f90}} 9 | ``` 10 | 11 | ```fortran 12 | {{#include ../../../src/structural/composite/composite_main.f90}} 13 | ``` -------------------------------------------------------------------------------- /doc/src/structural/facade.md: -------------------------------------------------------------------------------- 1 | # 外观模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/facade 4 | 5 | Go代码：https://refactoringguru.cn/design-patterns/facade/go/example 6 | 7 | ```fortran 8 | {{#include ../../../src/structural/facade/facade_module.f90}} 9 | ``` 10 | 11 | ```fortran 12 | {{#include ../../../src/structural/facade/facade_main.f90}} 13 | ``` -------------------------------------------------------------------------------- /doc/src/structural/proxy.md: -------------------------------------------------------------------------------- 1 | # 代理模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/proxy 4 | 5 | Go代码：https://refactoringguru.cn/design-patterns/proxy/go/example 6 | 7 | ```fortran 8 | {{#include ../../../src/structural/proxy/proxy_module.f90}} 9 | ``` 10 | 11 | ```fortran 12 | {{#include ../../../src/structural/proxy/proxy_main.f90}} 13 | ``` -------------------------------------------------------------------------------- /doc/src/structural/wrapper.md: -------------------------------------------------------------------------------- 1 | # 装饰模式 2 | 3 | 正文：https://refactoringguru.cn/design-patterns/decorator 4 | 5 | Go代码：https://refactoringguru.cn/design-patterns/decorator/go/example 6 | 7 | ```fortran 8 | {{#include ../../../src/structural/wrapper/wrapper_module.f90}} 9 | ``` 10 | 11 | ```fortran 12 | {{#include ../../../src/structural/wrapper/wrapper_main.f90}} 13 | ``` -------------------------------------------------------------------------------- /fpm.toml: -------------------------------------------------------------------------------- 1 | name = "Fortran-Design-Patterns" 2 | version = "0.3.0" 3 | license = "BSD-3" 4 | maintainer = "ZUO Zhihua" 5 | copyright = "Copyright 2021~2024 ZUO Zhihua" 6 | description = "Fortran Design Patterns" 7 | categories = ["Demo", "OOP", "Modern Fortran"] 8 | 9 | [library] 10 | source-dir = "src" 11 | 12 | [build] 13 | auto-tests = false 14 | 15 | [[test]] 16 | name = "CoR" 17 | source-dir = "src/behavioral/chain-of-responsibility" 18 | main = "CoR_main.f90" 19 | 20 | [[test]] 21 | name = "command" 22 | source-dir = "src/behavioral/command" 23 | main = "command_main.f90" 24 | 25 | [[test]] 26 | name = "iterator" 27 | source-dir = "src/behavioral/iterator" 28 | main = "iterator_main.f90" 29 | 30 | [[test]] 31 | name = "mediator" 32 | source-dir = "src/behavioral/mediator" 33 | main = "mediator_main.f90" 34 | 35 | [[test]] 36 | name = "memento" 37 | source-dir = "src/behavioral/memento" 38 | main = "memento_main.f90" 39 | 40 | [[test]] 41 | name = "observer" 42 | source-dir = "src/behavioral/observer" 43 | main = "observer_main.f90" 44 | 45 | [[test]] 46 | name = "state" 47 | source-dir = "src/behavioral/state" 48 | main = "state_main.f90" 49 | 50 | [[test]] 51 | name = "strategy" 52 | source-dir = "src/behavioral/strategy" 53 | main = "strategy_main.f90" 54 | 55 | [[test]] 56 | name = "strategy_ex" 57 | source-dir = "src/behavioral/strategy/extends" 58 | main = "strategy_main.f90" 59 | 60 | [[test]] 61 | name = "template_method" 62 | source-dir = "src/behavioral/template-method" 63 | main = "template_method_main.f90" 64 | 65 | [[test]] 66 | name = "visitor" 67 | source-dir = "src/behavioral/visitor" 68 | main = "visitor_main.f90" 69 | 70 | # - - - - - - - - - - 71 | 72 | [[test]] 73 | name = "abstract_factory" 74 | source-dir = "src/creational/abstract-factory" 75 | main = "abstract_factory_main.f90" 76 | 77 | [[test]] 78 | name = "builder" 79 | source-dir = "src/creational/builder" 80 | main = "builder_main.f90" 81 | 82 | [[test]] 83 | name = "factory" 84 | source-dir = "src/creational/factory" 85 | main = "factory_main.f90" 86 | 87 | [[test]] 88 | name = "prototype" 89 | source-dir = "src/creational/prototype" 90 | main = "prototype_main.f90" 91 | 92 | [[test]] 93 | name = "singleton" 94 | source-dir = "src/creational/singleton" 95 | main = "singleton_main.f90" 96 | 97 | # - - - - - - - - - - 98 | 99 | [[test]] 100 | name = "adapter" 101 | source-dir = "src/structural/adapter" 102 | main = "adapter_main.f90" 103 | 104 | [[test]] 105 | name = "bridge" 106 | source-dir = "src/structural/bridge" 107 | main = "bridge_main.f90" 108 | 109 | [[test]] 110 | name = "cache" 111 | source-dir = "src/structural/cache" 112 | main = "cache_main.f90" 113 | 114 | [[test]] 115 | name = "composite" 116 | source-dir = "src/structural/composite" 117 | main = "composite_main.f90" 118 | 119 | [[test]] 120 | name = "facade" 121 | source-dir = "src/structural/facade" 122 | main = "facade_main.f90" 123 | 124 | [[test]] 125 | name = "proxy" 126 | source-dir = "src/structural/proxy" 127 | main = "proxy_main.f90" 128 | 129 | [[test]] 130 | name = "wrapper" 131 | source-dir = "src/structural/wrapper" 132 | main = "wrapper_main.f90" 133 | 134 | # others 135 | [[test]] 136 | name = "interface-limit" 137 | source-dir = "src/others/interface-limit" 138 | main = "interface_limit_main.f90" 139 | 140 | [[test]] 141 | name = "interface-specific" 142 | source-dir = "src/others/interface-specific" 143 | main = "interface_specific_main.f90" 144 | -------------------------------------------------------------------------------- /src/behavioral/chain-of-responsibility/CoR_main.f90: -------------------------------------------------------------------------------- 1 | 2 | !> CoR: Patient visiting hospital 3 | program CoR_main 4 | 5 | use hospital_CoR 6 | 7 | type(cashier_type) :: c 8 | type(medical_type) :: m 9 | type(doctor_type) :: d 10 | type(reception_type) :: r 11 | 12 | type(patient_type) :: p1, p2 13 | 14 | !> Set next for departments 15 | call m%set_next(c) 16 | call d%set_next(m) 17 | call r%set_next(d) 18 | 19 | p1 = patient_type("abc", .true., .true., .true., .true.) 20 | !> Patient visiting 21 | print *, "> Patient `"//p1%name//"` : " 22 | call r%execute(p1) 23 | 24 | p2 = patient_type("def", .true., .false., .false., .false.) 25 | !> Patient visiting 26 | print *, "> Patient `"//p2%name//"` : " 27 | call r%execute(p2) 28 | 29 | !> Optional statements 30 | deallocate (m%next) 31 | deallocate (d%next) 32 | deallocate (r%next) 33 | 34 | end program CoR_main 35 | 36 | !> Results shall be: 37 | 38 | ! > Patient `abc` : 39 | ! Patient registration already done.✔️ 40 | ! Doctor checkup already done.✔️ 41 | ! Medicine already given to patient.✔️ 42 | ! Payment Done.✔️ 43 | ! > Patient `def` : 44 | ! Patient registration already done.✔️ 45 | ! Doctor checking patient. 46 | ! Medical giving medicine to patient. 47 | ! Cashier getting money from patient. -------------------------------------------------------------------------------- /src/behavioral/chain-of-responsibility/CoR_module.f90: -------------------------------------------------------------------------------- 1 | !> CoR: Hospital departments 2 | module hospital_CoR 3 | 4 | implicit none 5 | private 6 | 7 | public :: patient_type, department_type, reception_type, doctor_type, medical_type, cashier_type 8 | 9 | type patient_type 10 | character(:), allocatable :: name 11 | logical :: registration_done 12 | logical :: doctor_check_up_done 13 | logical :: medicine_done 14 | logical :: payment_done 15 | end type patient_type 16 | 17 | type, abstract :: department_type 18 | contains 19 | procedure(execute_procedure), deferred :: execute 20 | procedure(set_next_procedure), deferred :: set_next 21 | end type department_type 22 | 23 | abstract interface 24 | subroutine execute_procedure(self, p) 25 | import department_type, patient_type 26 | class(department_type), intent(inout) :: self 27 | type(patient_type), intent(inout) :: p 28 | end subroutine execute_procedure 29 | subroutine set_next_procedure(self, next) 30 | import department_type 31 | class(department_type), intent(inout) :: self 32 | class(department_type), intent(inout) :: next 33 | end subroutine set_next_procedure 34 | end interface 35 | 36 | type, extends(department_type) :: reception_type 37 | class(department_type), pointer :: next 38 | contains 39 | procedure :: execute => reception_type_execute 40 | procedure :: set_next => reception_type_set_next 41 | end type reception_type 42 | 43 | type, extends(department_type) :: doctor_type 44 | class(department_type), pointer :: next 45 | contains 46 | procedure :: execute => doctor_type_execute 47 | procedure :: set_next => doctor_type_set_next 48 | end type doctor_type 49 | 50 | type, extends(department_type) :: medical_type 51 | class(department_type), pointer :: next 52 | contains 53 | procedure :: execute => medicine_type_execute 54 | procedure :: set_next => medicine_type_set_next 55 | end type medical_type 56 | 57 | type, extends(department_type) :: cashier_type 58 | class(department_type), pointer :: next 59 | contains 60 | procedure :: execute => cashier_type_execute 61 | procedure :: set_next => cashier_type_set_next 62 | end type cashier_type 63 | 64 | contains 65 | 66 | subroutine reception_type_execute(self, p) 67 | class(reception_type), intent(inout) :: self 68 | type(patient_type), intent(inout) :: p 69 | 70 | if (p%registration_done) then 71 | print *, "Patient registration already done.✔️" 72 | call self%next%execute(p) 73 | return 74 | end if 75 | 76 | print *, "Reception registering patient." 77 | p%registration_done = .true. 78 | call self%next%execute(p) 79 | 80 | end subroutine reception_type_execute 81 | 82 | subroutine reception_type_set_next(self, next) 83 | class(reception_type), intent(inout) :: self 84 | class(department_type), intent(inout) :: next 85 | 86 | allocate (self%next, source=next) 87 | 88 | end subroutine reception_type_set_next 89 | 90 | subroutine doctor_type_execute(self, p) 91 | class(doctor_type), intent(inout) :: self 92 | type(patient_type), intent(inout) :: p 93 | 94 | if (p%doctor_check_up_done) then 95 | print *, "Doctor checkup already done.✔️" 96 | call self%next%execute(p) 97 | return 98 | end if 99 | 100 | print *, "Doctor checking patient." 101 | p%doctor_check_up_done = .true. 102 | call self%next%execute(p) 103 | 104 | end subroutine doctor_type_execute 105 | 106 | subroutine doctor_type_set_next(self, next) 107 | class(doctor_type), intent(inout) :: self 108 | class(department_type), intent(inout) :: next 109 | 110 | allocate (self%next, source=next) 111 | 112 | end subroutine doctor_type_set_next 113 | 114 | subroutine medicine_type_execute(self, p) 115 | class(medical_type), intent(inout) :: self 116 | type(patient_type), intent(inout) :: p 117 | 118 | if (p%medicine_done) then 119 | print *, "Medicine already given to patient.✔️" 120 | call self%next%execute(p) 121 | return 122 | end if 123 | 124 | print *, "Medical giving medicine to patient." 125 | p%medicine_done = .true. 126 | call self%next%execute(p) 127 | 128 | end subroutine medicine_type_execute 129 | 130 | subroutine medicine_type_set_next(self, next) 131 | class(medical_type), intent(inout) :: self 132 | class(department_type), intent(inout) :: next 133 | 134 | allocate (self%next, source=next) 135 | 136 | end subroutine medicine_type_set_next 137 | 138 | subroutine cashier_type_execute(self, p) 139 | class(cashier_type), intent(inout) :: self 140 | type(patient_type), intent(inout) :: p 141 | 142 | if (p%payment_done) then 143 | print *, "Payment Done.✔️" 144 | return 145 | end if 146 | 147 | print *, "Cashier getting money from patient." 148 | p%payment_done = .true. 149 | 150 | end subroutine cashier_type_execute 151 | 152 | subroutine cashier_type_set_next(self, next) 153 | class(cashier_type), intent(inout) :: self 154 | class(department_type), intent(inout) :: next 155 | 156 | allocate (self%next, source=next) 157 | 158 | end subroutine cashier_type_set_next 159 | 160 | end module hospital_CoR 161 | -------------------------------------------------------------------------------- /src/behavioral/command/command_main.f90: -------------------------------------------------------------------------------- 1 | !> Reference: https://refactoring.guru/design-patterns/command/go/example 2 | program test_command 3 | 4 | use command_pattern, only: tv_type, on_command_type, off_command_type, button_type 5 | type(tv_type) :: t 6 | type(on_command_type) :: on_c 7 | type(off_command_type) :: off_c 8 | 9 | type(button_type) :: on_b 10 | type(button_type) :: off_b 11 | 12 | !> Linking 13 | allocate (on_c%d, source=t) 14 | allocate (off_c%d, source=t) 15 | 16 | allocate (on_b%c, source=on_c) 17 | allocate (off_b%c, source=off_c) 18 | 19 | !> Operating 20 | call on_b%press() 21 | call off_b%press() 22 | 23 | !> Free memory. 24 | deallocate (on_c%d) 25 | deallocate (off_c%d) 26 | deallocate (on_b%c) 27 | deallocate (off_b%c) 28 | 29 | end program test_command 30 | 31 | !> Results shall be: 32 | 33 | ! Turning tv on. ✔️ 34 | ! Turning tv off. ❌ -------------------------------------------------------------------------------- /src/behavioral/command/command_module.f90: -------------------------------------------------------------------------------- 1 | !> Reference: https://refactoring.guru/design-patterns/command/go/example 2 | module command_pattern 3 | 4 | implicit none 5 | private 6 | 7 | public :: tv_type, on_command_type, off_command_type, button_type 8 | 9 | !> Abstract classes 10 | 11 | type, abstract :: command_type 12 | contains 13 | procedure(execute_procedure), deferred :: execute 14 | end type command_type 15 | 16 | type, abstract :: device_type 17 | contains 18 | procedure(on_procedure), deferred :: on 19 | procedure(off_procedure), deferred :: off 20 | end type device_type 21 | 22 | abstract interface 23 | subroutine execute_procedure(self) 24 | import command_type 25 | class(command_type), intent(inout) :: self 26 | end subroutine execute_procedure 27 | subroutine on_procedure(self) 28 | import device_type 29 | class(device_type), intent(inout) :: self 30 | end subroutine on_procedure 31 | subroutine off_procedure(self) 32 | import device_type 33 | class(device_type), intent(inout) :: self 34 | end subroutine off_procedure 35 | end interface 36 | 37 | !> Specific Objects 38 | 39 | type, extends(command_type) :: on_command_type 40 | class(device_type), pointer :: d 41 | contains 42 | procedure :: execute => on_command_type_execute 43 | end type on_command_type 44 | 45 | type, extends(command_type) :: off_command_type 46 | class(device_type), pointer :: d 47 | contains 48 | procedure :: execute => off_command_type_execute 49 | end type off_command_type 50 | 51 | type, extends(device_type) :: tv_type 52 | logical :: is_running 53 | contains 54 | procedure :: on => tv_type_on 55 | procedure :: off => tv_type_off 56 | end type tv_type 57 | 58 | type :: button_type 59 | class(command_type), pointer :: c 60 | contains 61 | procedure :: press 62 | end type button_type 63 | 64 | contains 65 | 66 | subroutine press(self) 67 | class(button_type), intent(inout) :: self 68 | call self%c%execute() 69 | end subroutine press 70 | 71 | subroutine on_command_type_execute(self) 72 | class(on_command_type), intent(inout) :: self 73 | call self%d%on() 74 | end subroutine on_command_type_execute 75 | 76 | subroutine off_command_type_execute(self) 77 | class(off_command_type), intent(inout) :: self 78 | call self%d%off() 79 | end subroutine off_command_type_execute 80 | 81 | subroutine tv_type_on(self) 82 | class(tv_type), intent(inout) :: self 83 | self%is_running = .true. 84 | print *, "Turning tv on. ✔️" 85 | end subroutine tv_type_on 86 | 87 | subroutine tv_type_off(self) 88 | class(tv_type), intent(inout) :: self 89 | self%is_running = .false. 90 | print *, "Turning tv off. ❌" 91 | end subroutine tv_type_off 92 | 93 | end module command_pattern 94 | -------------------------------------------------------------------------------- /src/behavioral/iterator/iterator_main.f90: -------------------------------------------------------------------------------- 1 | program iterator_main 2 | 3 | use, intrinsic :: iso_fortran_env, only: int8 4 | use iterator_module, only: user_type, user_collection_type, user_iterator_type, iterator_type 5 | 6 | type(user_type) :: user1, user2, user 7 | type(user_collection_type) :: user_collection 8 | ! TODO: 9 | class(iterator_type), allocatable :: iterator 10 | 11 | user1 = user_type(name="A", age=30_int8) 12 | user2 = user_type(name="B", age=20_int8) 13 | 14 | user_collection = user_collection_type(users=[user1, user2]) 15 | 16 | !> Specific iterator 17 | allocate (user_iterator_type :: iterator) 18 | iterator = user_collection%create_iterator() 19 | 20 | do while (iterator%has_next()) 21 | user = iterator%get_next() 22 | print "(3A,I3)", "User is ", user%name, ", age is ", user%age 23 | end do 24 | 25 | deallocate (iterator) 26 | 27 | end program iterator_main 28 | 29 | !> Results shall be: 30 | 31 | ! User is A, age is 30 32 | ! User is B, age is 20 -------------------------------------------------------------------------------- /src/behavioral/iterator/iterator_module.f90: -------------------------------------------------------------------------------- 1 | module iterator_module 2 | 3 | use, intrinsic :: iso_fortran_env, only: int8 4 | implicit none 5 | private 6 | 7 | public :: user_type, user_collection_type, user_iterator_type, iterator_type 8 | 9 | !> Abstract types 10 | 11 | !> Collection 12 | type, abstract :: collection_type 13 | contains 14 | procedure(collection_type_create_iterator), deferred :: create_iterator 15 | end type collection_type 16 | 17 | !> Iterator 18 | type, abstract :: iterator_type 19 | contains 20 | procedure(iterator_t_has_next), deferred :: has_next 21 | procedure(iterator_t_get_next), deferred :: get_next 22 | end type iterator_type 23 | 24 | !> User 25 | type user_type 26 | character(:), allocatable :: name 27 | integer(int8) :: age 28 | end type user_type 29 | 30 | abstract interface 31 | 32 | function collection_type_create_iterator(self) result(iterator) 33 | import iterator_type, collection_type 34 | !> TODO: 35 | class(collection_type), intent(in) :: self 36 | class(iterator_type), allocatable :: iterator 37 | end function collection_type_create_iterator 38 | 39 | logical function iterator_t_has_next(self) 40 | import iterator_type 41 | class(iterator_type), intent(in) :: self 42 | end function iterator_t_has_next 43 | 44 | type(user_type) function iterator_t_get_next(self) 45 | import user_type, iterator_type 46 | class(iterator_type), intent(inout) :: self 47 | end function iterator_t_get_next 48 | 49 | end interface 50 | 51 | !> Specific types 52 | 53 | !> User collection 54 | type, extends(collection_type) :: user_collection_type 55 | type(user_type), allocatable :: users(:) 56 | contains 57 | procedure :: create_iterator => user_collection_t_create_iterator 58 | end type user_collection_type 59 | 60 | !> User iterator 61 | type, extends(iterator_type) :: user_iterator_type 62 | integer :: index 63 | type(user_type), allocatable :: users(:) 64 | contains 65 | procedure :: has_next => user_iterator_t_has_next 66 | procedure :: get_next => user_iterator_t_get_next 67 | end type user_iterator_type 68 | 69 | contains 70 | 71 | function user_collection_t_create_iterator(self) result(iterator) 72 | class(user_collection_type), intent(in) :: self 73 | class(iterator_type), allocatable :: iterator 74 | ! TODO: 75 | iterator = user_iterator_type(index=0, users=self%users) 76 | end function user_collection_t_create_iterator 77 | 78 | logical function user_iterator_t_has_next(self) result(has) 79 | class(user_iterator_type), intent(in) :: self 80 | 81 | has = merge(.true., .false., self%index < size(self%users)) 82 | 83 | end function user_iterator_t_has_next 84 | 85 | type(user_type) function user_iterator_t_get_next(self) result(user) 86 | class(user_iterator_type), intent(inout) :: self 87 | 88 | self%index = self%index + 1 89 | user = self%users(self%index) 90 | 91 | end function user_iterator_t_get_next 92 | 93 | end module iterator_module 94 | -------------------------------------------------------------------------------- /src/behavioral/mediator/mediator_main.f90: -------------------------------------------------------------------------------- 1 | program mediator_main 2 | 3 | use mediator_module, only: station_manager_type,passenger_train_type,freight_train_type 4 | implicit none 5 | type(station_manager_type), target :: station_manager 6 | type(passenger_train_type) :: passenger_train 7 | type(freight_train_type) :: freight_train 8 | 9 | allocate(station_manager%list(0)) 10 | passenger_train%mediator => station_manager 11 | freight_train%mediator => station_manager 12 | 13 | call passenger_train%arrive() 14 | call freight_train%arrive() 15 | call passenger_train%depart() 16 | 17 | end program mediator_main 18 | 19 | !> Results shall be: 20 | 21 | ! Passenger train: arrived 22 | ! Freight train: arrival blocked, waiting 23 | ! Passenger train: leaving 24 | ! Freight train: arrival permitted, arriving 25 | ! Freight train: arrived -------------------------------------------------------------------------------- /src/behavioral/mediator/mediator_module.f90: -------------------------------------------------------------------------------- 1 | module mediator_module 2 | 3 | implicit none 4 | private 5 | 6 | public :: station_manager_type, passenger_train_type, freight_train_type 7 | 8 | type, abstract :: train_type 9 | contains 10 | procedure(train_type_arrive), deferred :: arrive 11 | procedure(train_type_depart), deferred :: depart 12 | procedure(train_type_permit_arrival), deferred :: permit_arrival 13 | end type train_type 14 | 15 | type, abstract :: mediator_t 16 | contains 17 | procedure(mediator_type_can_arrive), deferred :: can_arrive 18 | procedure(mediator_type_notify_about_departure), deferred :: notify_about_departure 19 | end type mediator_t 20 | 21 | abstract interface 22 | 23 | subroutine train_type_arrive(self) 24 | import train_type 25 | class(train_type), intent(inout) :: self 26 | end subroutine train_type_arrive 27 | 28 | subroutine train_type_depart(self) 29 | import train_type 30 | class(train_type), intent(inout) :: self 31 | end subroutine train_type_depart 32 | 33 | subroutine train_type_permit_arrival(self) 34 | import train_type 35 | class(train_type), intent(inout) :: self 36 | end subroutine train_type_permit_arrival 37 | 38 | logical function mediator_type_can_arrive(self, train) result(can) 39 | import mediator_t, train_type 40 | class(mediator_t), intent(inout) :: self 41 | class(train_type), intent(in), target :: train 42 | end function mediator_type_can_arrive 43 | 44 | subroutine mediator_type_notify_about_departure(self) 45 | import mediator_t 46 | class(mediator_t), intent(inout) :: self 47 | end subroutine mediator_type_notify_about_departure 48 | 49 | end interface 50 | 51 | type, extends(train_type) :: passenger_train_type 52 | class(mediator_t), pointer :: mediator 53 | contains 54 | procedure :: arrive => passenger_train_type_arrive 55 | procedure :: depart => passenger_train_type_depart 56 | procedure :: permit_arrival => passenger_train_type_permit_arrival 57 | end type passenger_train_type 58 | 59 | type, extends(train_type) :: freight_train_type 60 | class(mediator_t), pointer :: mediator 61 | contains 62 | procedure :: arrive => freight_train_type_arrive 63 | procedure :: depart => freight_train_type_depart 64 | procedure :: permit_arrival => freight_train_type_permit_arrival 65 | end type freight_train_type 66 | 67 | type node_t 68 | class(train_type), pointer :: train 69 | end type node_t 70 | 71 | type, extends(mediator_t) :: station_manager_type 72 | logical :: is_platform_free = .true. 73 | type(node_t), allocatable :: list(:) 74 | contains 75 | procedure :: can_arrive => station_manager_type_can_arrive 76 | procedure :: notify_about_departure => station_manager_type_notify_about_departure 77 | end type station_manager_type 78 | 79 | contains 80 | 81 | subroutine passenger_train_type_arrive(self) 82 | class(passenger_train_type), intent(inout) :: self 83 | if (.not. self%mediator%can_arrive(self)) then 84 | print *, "Passenger train: arrival blocked, waiting" 85 | return 86 | end if 87 | print *, "Passenger train: arrived" 88 | end subroutine passenger_train_type_arrive 89 | 90 | subroutine passenger_train_type_depart(self) 91 | class(passenger_train_type), intent(inout) :: self 92 | print *, "Passenger train: leaving" 93 | call self%mediator%notify_about_departure() 94 | end subroutine passenger_train_type_depart 95 | 96 | subroutine passenger_train_type_permit_arrival(self) 97 | class(passenger_train_type), intent(inout) :: self 98 | print *, "Passenger train: arrival permitted, arriving" 99 | call self%arrive() 100 | end subroutine passenger_train_type_permit_arrival 101 | 102 | subroutine freight_train_type_arrive(self) 103 | class(freight_train_type), intent(inout) :: self 104 | 105 | if (.not. self%mediator%can_arrive(self)) then 106 | print *, "Freight train: arrival blocked, waiting" 107 | return 108 | end if 109 | print *, "Freight train: arrived" 110 | 111 | end subroutine freight_train_type_arrive 112 | 113 | subroutine freight_train_type_depart(self) 114 | class(freight_train_type), intent(inout) :: self 115 | print *, "freight train: leaving" 116 | call self%mediator%notify_about_departure() 117 | end subroutine freight_train_type_depart 118 | 119 | subroutine freight_train_type_permit_arrival(self) 120 | class(freight_train_type), intent(inout) :: self 121 | print *, "Freight train: arrival permitted, arriving" 122 | call self%arrive() 123 | end subroutine freight_train_type_permit_arrival 124 | 125 | logical function station_manager_type_can_arrive(self, train) result(can) 126 | class(station_manager_type), intent(inout) :: self 127 | class(train_type), intent(in), target :: train 128 | 129 | if (self%is_platform_free) then 130 | self%is_platform_free = .false. 131 | can = .true. 132 | return 133 | end if 134 | self%list = [self%list, node_t(train)] 135 | can = .false. 136 | 137 | end function station_manager_type_can_arrive 138 | 139 | subroutine station_manager_type_notify_about_departure(self) 140 | class(station_manager_type), intent(inout) :: self 141 | class(train_type), pointer :: train 142 | 143 | if (.not. self%is_platform_free) then 144 | self%is_platform_free = .true. 145 | end if 146 | if (size(self%list) > 0) then 147 | train => self%list(1)%train 148 | !> 内存泄露 149 | self%list = self%list(2:) 150 | call train%permit_arrival() 151 | end if 152 | 153 | end subroutine station_manager_type_notify_about_departure 154 | 155 | end module mediator_module 156 | -------------------------------------------------------------------------------- /src/behavioral/memento/memento_main.f90: -------------------------------------------------------------------------------- 1 | program memento_main 2 | 3 | use memento_module, only: caretaker_type, originator_type 4 | 5 | type(caretaker_type) :: caretaker 6 | type(originator_type) :: originator 7 | 8 | allocate (caretaker%memento(0)) 9 | originator%state = "A" 10 | 11 | print *, "Originator state: ", originator%get_state() 12 | call caretaker%add_memento(originator%create_memento()) 13 | 14 | call originator%set_state("B") 15 | print *, "Originator current state: ", originator%get_state() 16 | call caretaker%add_memento(originator%create_memento()) 17 | 18 | call originator%set_state("C") 19 | print *, "Originator current state: ", originator%get_state() 20 | call caretaker%add_memento(originator%create_memento()) 21 | 22 | call originator%restore_memento(caretaker%get_memento(2)) 23 | print *, "Restored to state: ", originator%get_state() 24 | 25 | call originator%restore_memento(caretaker%get_memento(1)) 26 | print *, "Restored to state: ", originator%get_state() 27 | 28 | end program memento_main 29 | 30 | !> Results shall be: 31 | 32 | ! Originator state: A 33 | ! Originator current state: B 34 | ! Originator current state: C 35 | ! Restored to state: B 36 | ! Restored to state: A 37 | -------------------------------------------------------------------------------- /src/behavioral/memento/memento_module.f90: -------------------------------------------------------------------------------- 1 | module memento_module 2 | 3 | implicit none 4 | private 5 | 6 | public :: caretaker_type, originator_type 7 | 8 | type originator_type 9 | character(:), allocatable :: state 10 | contains 11 | procedure :: create_memento => originator_t_create_memento 12 | procedure :: restore_memento => originator_t_restore_memento 13 | procedure :: set_state => originator_t_set_state 14 | procedure :: get_state => originator_t_get_state 15 | end type originator_type 16 | 17 | type memento_type 18 | character(:), allocatable :: state 19 | end type memento_type 20 | 21 | type caretaker_type 22 | type(memento_type), allocatable :: memento(:) 23 | contains 24 | procedure :: add_memento => caretaker_t_add_memento 25 | procedure :: get_memento => caretaker_t_get_memento 26 | end type caretaker_type 27 | 28 | contains 29 | 30 | function originator_t_create_memento(self) result(memento) 31 | class(originator_type), intent(inout) :: self 32 | type(memento_type) :: memento 33 | memento%state = self%state 34 | end function originator_t_create_memento 35 | 36 | subroutine originator_t_restore_memento(self, memento) 37 | class(originator_type), intent(inout) :: self 38 | type(memento_type), intent(in) :: memento 39 | self%state = memento%state 40 | end subroutine originator_t_restore_memento 41 | 42 | subroutine originator_t_set_state(self, state) 43 | class(originator_type), intent(inout) :: self 44 | character(*), intent(in) :: state 45 | self%state = state 46 | end subroutine originator_t_set_state 47 | 48 | function originator_t_get_state(self) result(state) 49 | class(originator_type), intent(inout) :: self 50 | character(:), allocatable :: state 51 | state = self%state 52 | end function originator_t_get_state 53 | 54 | subroutine caretaker_t_add_memento(self, memento) 55 | class(caretaker_type), intent(inout) :: self 56 | type(memento_type), intent(in) :: memento 57 | self%memento = [self%memento, memento] 58 | end subroutine caretaker_t_add_memento 59 | 60 | function caretaker_t_get_memento(self, index) result(memento) 61 | class(caretaker_type), intent(inout) :: self 62 | integer, intent(in) :: index 63 | type(memento_type) :: memento 64 | memento = self%memento(index) 65 | end function caretaker_t_get_memento 66 | 67 | end module memento_module 68 | -------------------------------------------------------------------------------- /src/behavioral/observer/observer_main.f90: -------------------------------------------------------------------------------- 1 | !> Reference: https://refactoring.guru/design-patterns/observer/go/example 2 | program test_observer 3 | 4 | use observer_pattern, only: item_type, customer_type, new_item 5 | type(item_type) :: shirt_item 6 | type(customer_type) :: observer_first, observer_second, observer_third 7 | 8 | !> A shirt item 9 | shirt_item = new_item("A Shirt") 10 | 11 | !> Some customers 12 | observer_first = customer_type(ID="abc@gmail.com") 13 | observer_second = customer_type(ID="def@gmail.com") 14 | observer_third = customer_type(ID="xyz@foxmail.com") 15 | 16 | !> Scene 1 17 | call shirt_item%register(observer_first) 18 | call shirt_item%register(observer_second) 19 | call shirt_item%update_availability() 20 | 21 | !> Scene 2 22 | call shirt_item%deregister(observer_first) 23 | call shirt_item%register(observer_third) 24 | call shirt_item%update_availability() 25 | 26 | end program test_observer 27 | 28 | !> Results shall be: 29 | 30 | ! > Item A Shirt 👔 is now in stock. 31 | ! Sending email to customer abc@gmail.com 📨 for item A Shirt. 32 | ! Sending email to customer def@gmail.com 📨 for item A Shirt. 33 | ! > Item A Shirt 👔 is now in stock. 34 | ! Sending email to customer def@gmail.com 📨 for item A Shirt. 35 | ! Sending email to customer xyz@foxmail.com 📨 for item A Shirt. -------------------------------------------------------------------------------- /src/behavioral/observer/observer_module.f90: -------------------------------------------------------------------------------- 1 | !> Reference: https://refactoring.guru/design-patterns/observer/go/example 2 | module observer_pattern 3 | 4 | implicit none 5 | private 6 | 7 | public :: item_type, customer_type, new_item 8 | 9 | !> Abstract classes 10 | type, abstract :: subject_type 11 | contains 12 | procedure(register_procedure), deferred :: register 13 | procedure(deregister_procedure), deferred :: deregister 14 | procedure(notify_all_procedure), deferred :: notify_all 15 | end type subject_type 16 | 17 | type, abstract :: observer_type 18 | contains 19 | procedure(update_procedure), deferred :: update 20 | procedure(get_ID_procedure), deferred :: get_ID 21 | end type observer_type 22 | 23 | !> We cannot directly use `class(observer), allocatable :: o_list(:)` 24 | !> instead of `type(node), allocatable :: o_list(:)`. 25 | type node_type 26 | class(observer_type), allocatable :: o 27 | end type node_type 28 | 29 | abstract interface 30 | subroutine register_procedure(self, o) 31 | import subject_type, observer_type 32 | class(subject_type), intent(inout) :: self 33 | class(observer_type), intent(inout) :: o 34 | end subroutine register_procedure 35 | subroutine deregister_procedure(self, o) 36 | import subject_type, observer_type 37 | class(subject_type), intent(inout) :: self 38 | class(observer_type), intent(inout) :: o 39 | end subroutine deregister_procedure 40 | subroutine notify_all_procedure(self) 41 | import subject_type 42 | class(subject_type), intent(inout) :: self 43 | end subroutine notify_all_procedure 44 | subroutine update_procedure(self, s) 45 | import observer_type 46 | class(observer_type), intent(inout) :: self 47 | character(len=*), intent(inout) :: s 48 | end subroutine update_procedure 49 | function get_ID_procedure(self) result(result) 50 | import observer_type 51 | class(observer_type), intent(inout) :: self 52 | character(len=:), allocatable :: result 53 | end function get_ID_procedure 54 | end interface 55 | 56 | !> Specific objects 57 | 58 | type, extends(subject_type) :: item_type 59 | type(node_type), allocatable :: o_list(:) 60 | character(len=:), allocatable :: name 61 | logical :: in_stock 62 | contains 63 | procedure :: update_availability 64 | procedure :: register 65 | procedure :: deregister 66 | procedure :: notify_all 67 | end type item_type 68 | 69 | type, extends(observer_type) :: customer_type 70 | character(len=:), allocatable :: ID 71 | contains 72 | procedure :: update 73 | procedure :: get_ID 74 | end type customer_type 75 | 76 | contains 77 | 78 | !> Constructor of `item`. 79 | function new_item(name) result(i) 80 | character(*), intent(in) :: name 81 | type(item_type) :: i 82 | i%name = name 83 | end function new_item 84 | 85 | !> Remove a object from the subscription array. 86 | function remove_from_slice(o_list, o_to_remove) result(result) 87 | type(node_type), intent(inout) :: o_list(:) 88 | class(observer_type), intent(inout) :: o_to_remove 89 | type(node_type), allocatable :: result(:) 90 | character(len=:), allocatable :: id 91 | integer :: i, j 92 | i = size(o_list) 93 | id = o_to_remove%get_ID() 94 | do j = 1, i 95 | if (o_list(j)%o%get_ID() == id) then 96 | allocate (result(i - 1), source=[o_list(:j - 1), o_list(j + 1:)]) 97 | return 98 | end if 99 | end do 100 | result = o_list 101 | end function remove_from_slice 102 | 103 | !> Append a object to the subscription array. 104 | function append_slice(o_list, o_to_append) result(result) 105 | type(node_type), intent(inout), allocatable :: o_list(:) 106 | class(observer_type), intent(inout) :: o_to_append 107 | type(node_type), allocatable :: result(:) 108 | integer :: i 109 | if (.not. allocated(o_list)) then 110 | allocate (result(1)) 111 | allocate (result(1)%o, source=o_to_append) 112 | else 113 | i = size(o_list) 114 | allocate (result(i + 1)) 115 | result(1:i) = o_list 116 | allocate (result(i + 1)%o, source=o_to_append) 117 | end if 118 | end function append_slice 119 | 120 | subroutine update_availability(self) 121 | class(item_type), intent(inout) :: self 122 | print *, "> Item "//self%name//" 👔 is now in stock." 123 | self%in_stock = .true. 124 | call self%notify_all() 125 | end subroutine update_availability 126 | 127 | subroutine register(self, o) 128 | class(item_type), intent(inout) :: self 129 | class(observer_type), intent(inout) :: o 130 | self%o_list = append_slice(self%o_list, o) 131 | end subroutine register 132 | 133 | subroutine deregister(self, o) 134 | class(item_type), intent(inout) :: self 135 | class(observer_type), intent(inout) :: o 136 | self%o_list = remove_from_slice(self%o_list, o) 137 | end subroutine deregister 138 | 139 | subroutine notify_all(self) 140 | class(item_type), intent(inout) :: self 141 | integer :: i 142 | do i = 1, size(self%o_list) 143 | call self%o_list(i)%o%update(self%name) 144 | end do 145 | end subroutine notify_all 146 | 147 | subroutine update(self, s) 148 | class(customer_type), intent(inout) :: self 149 | character(len=*), intent(inout) :: s 150 | print *, "Sending email to customer "//self%ID//" 📨 for item "//s//"." 151 | end subroutine update 152 | 153 | function get_ID(self) result(result) 154 | class(customer_type), intent(inout) :: self 155 | character(len=:), allocatable :: result 156 | result = self%ID 157 | end function get_ID 158 | 159 | end module observer_pattern 160 | -------------------------------------------------------------------------------- /src/behavioral/state/state_main.f90: -------------------------------------------------------------------------------- 1 | program state_main 2 | 3 | use state_module, only: person_type 4 | implicit none 5 | 6 | type(person_type) :: person 7 | call person%hungry_state%no_hungry 8 | call person%work 9 | call person%work 10 | call person%eat 11 | call person%eat 12 | 13 | end program state_main 14 | 15 | !> Results shall be: 16 | 17 | ! Ok, let us do work.. 18 | ! I am hungry, no work!! 19 | ! Eatting.. 20 | ! Already baole!! 21 | 22 | -------------------------------------------------------------------------------- /src/behavioral/state/state_module.f90: -------------------------------------------------------------------------------- 1 | module state_module 2 | 3 | implicit none 4 | private 5 | 6 | public :: person_type 7 | 8 | type :: hungry_state_type 9 | logical :: state 10 | contains 11 | procedure :: hungry => hungry_state_t_hungry 12 | procedure :: no_hungry => hungry_state_t_no_hungry 13 | end type hungry_state_type 14 | 15 | type :: person_type 16 | type(hungry_state_type) :: hungry_state 17 | contains 18 | procedure :: eat => person_t_eat 19 | procedure :: work => person_t_work 20 | end type 21 | 22 | contains 23 | 24 | subroutine person_t_eat(self) 25 | class(person_type), intent(inout) :: self 26 | if (self%hungry_state%state) then 27 | print *, "Eatting.." 28 | !!// 改变状态 29 | call self%hungry_state%no_hungry 30 | else 31 | print *, "Already baole!!" 32 | end if 33 | end subroutine person_t_eat 34 | 35 | subroutine person_t_work(self) 36 | class(person_type), intent(inout) :: self 37 | if (self%hungry_state%state) then 38 | print *, "I am hungry, no work!!" 39 | else 40 | print *, "Ok, let us do work.." 41 | call self%hungry_state%hungry 42 | end if 43 | end subroutine person_t_work 44 | 45 | subroutine hungry_state_t_hungry(self) 46 | class(hungry_state_type), intent(inout) :: self 47 | self%state = .true. 48 | end subroutine hungry_state_t_hungry 49 | 50 | subroutine hungry_state_t_no_hungry(self) 51 | class(hungry_state_type), intent(inout) :: self 52 | self%state = .false. 53 | end subroutine hungry_state_t_no_hungry 54 | 55 | end module state_module 56 | -------------------------------------------------------------------------------- /src/behavioral/strategy/extends/strategy_main.f90: -------------------------------------------------------------------------------- 1 | !> 2 | !> 策略模式更倾向于方法策略，而不是类策略的时候，可以使用函数方法代替类声明。 3 | module strategy_extends_m 4 | 5 | implicit none 6 | private 7 | 8 | public :: calculator_type 9 | 10 | type calculator_type 11 | procedure(fcn), nopass, pointer :: strategy 12 | contains 13 | procedure, pass :: set_strategy => calculator_type_set_strategy 14 | procedure, pass :: calc => calculator_type_calc 15 | end type calculator_type 16 | 17 | abstract interface 18 | integer function fcn(a, b) result(c) 19 | integer, intent(in) :: a, b 20 | end function fcn 21 | end interface 22 | 23 | contains 24 | 25 | subroutine calculator_type_set_strategy(self, strategy) 26 | class(calculator_type), intent(inout) :: self 27 | procedure(fcn) :: strategy 28 | self%strategy => strategy 29 | end subroutine calculator_type_set_strategy 30 | 31 | integer function calculator_type_calc(self, a, b) result(c) 32 | class(calculator_type), intent(in) :: self 33 | integer, intent(in) :: a, b 34 | c = self%strategy(a, b) 35 | end function calculator_type_calc 36 | 37 | end module strategy_extends_m 38 | 39 | program main 40 | 41 | use strategy_extends_m, only: calculator_type 42 | implicit none 43 | type(calculator_type) :: calculator 44 | 45 | call calculator%set_strategy(add) 46 | print *, calculator%calc(1, 1) 47 | 48 | call calculator%set_strategy(sub) 49 | print *, calculator%calc(1, 1) 50 | 51 | contains 52 | 53 | integer function add(a, b) result(c) 54 | integer, intent(in) :: a, b 55 | c = a + b 56 | end function add 57 | 58 | integer function sub(a, b) result(c) 59 | integer, intent(in) :: a, b 60 | c = a - b 61 | end function sub 62 | 63 | end program main 64 | -------------------------------------------------------------------------------- /src/behavioral/strategy/strategy_main.f90: -------------------------------------------------------------------------------- 1 | program strategy_main 2 | 3 | use strategy_module, only: add_type, sub_type, calculator_type 4 | implicit none 5 | type(add_type) :: add 6 | type(sub_type) :: sub 7 | type(calculator_type) :: calculator 8 | 9 | call calculator%set_strategy(add) 10 | print *, "Add:", calculator%strategy%calc(1, 1) 11 | 12 | call calculator%set_strategy(sub) 13 | print *, "Sub:", calculator%strategy%calc(1, 1) 14 | 15 | end program strategy_main 16 | 17 | !> Results shall be: 18 | 19 | ! Add: 2 20 | ! Sub: 0 -------------------------------------------------------------------------------- /src/behavioral/strategy/strategy_module.f90: -------------------------------------------------------------------------------- 1 | module strategy_module 2 | 3 | implicit none 4 | private 5 | 6 | public :: add_type, sub_type, calculator_type 7 | 8 | type, abstract :: strategy_type 9 | contains 10 | procedure(strategy_type_calc), deferred :: calc 11 | end type strategy_type 12 | 13 | abstract interface 14 | integer function strategy_type_calc(self, a, b) result(c) 15 | import strategy_type 16 | class(strategy_type), intent(inout) :: self 17 | integer, intent(in) :: a, b 18 | end function strategy_type_calc 19 | end interface 20 | 21 | type, extends(strategy_type) :: add_type 22 | contains 23 | procedure :: calc => add_type_calc 24 | end type add_type 25 | 26 | type, extends(strategy_type) :: sub_type 27 | contains 28 | procedure :: calc => sub_type_calc 29 | end type sub_type 30 | 31 | type calculator_type 32 | class(strategy_type), pointer :: strategy 33 | contains 34 | procedure :: set_strategy => calculator_type_set_strategy 35 | procedure :: get_result => calculator_type_get_result 36 | end type calculator_type 37 | 38 | contains 39 | 40 | integer function add_type_calc(self, a, b) result(c) 41 | class(add_type), intent(inout) :: self 42 | integer, intent(in) :: a, b 43 | c = a + b 44 | end function add_type_calc 45 | 46 | integer function sub_type_calc(self, a, b) result(c) 47 | class(sub_type), intent(inout) :: self 48 | integer, intent(in) :: a, b 49 | c = a - b 50 | end function sub_type_calc 51 | 52 | subroutine calculator_type_set_strategy(self, strategy) 53 | class(calculator_type), intent(inout) :: self 54 | class(strategy_type), intent(in), target :: strategy 55 | self%strategy => strategy 56 | end subroutine calculator_type_set_strategy 57 | 58 | integer function calculator_type_get_result(self, a, b) result(c) 59 | class(calculator_type), intent(inout) :: self 60 | integer, intent(in) :: a, b 61 | c = self%strategy%calc(a, b) 62 | end function calculator_type_get_result 63 | 64 | end module strategy_module 65 | -------------------------------------------------------------------------------- /src/behavioral/template-method/template_method_main.f90: -------------------------------------------------------------------------------- 1 | program template_method_main 2 | 3 | use template_method_module, only: otp_type, sms_type, email_type 4 | 5 | type(otp_type) :: otp 6 | type(sms_type), target :: sms_otp 7 | type(email_type), target :: email_otp 8 | 9 | sms_otp = sms_type() 10 | otp%iopt => sms_otp 11 | call otp%gen_and_send_otp(4) 12 | 13 | write (*, *) 14 | 15 | email_otp = email_type() 16 | otp%iopt => email_otp 17 | call otp%gen_and_send_otp(4) 18 | 19 | end program template_method_main 20 | 21 | !> Results shall be: 22 | 23 | ! SMS: generating random otp 1234 24 | ! SMS: saving otp: 1234 to cache 25 | ! SMS: sending sms: SMS OTP for login is 1234 26 | ! SMS: publishing metric 27 | ! 28 | ! EMAIL: generating random otp 1234 29 | ! EMAIL: saving otp: 1234 to cache 30 | ! EMAIL: sending email: EMAIL OTP for login is 1234 31 | ! EMAIL: publishing metric -------------------------------------------------------------------------------- /src/behavioral/template-method/template_method_module.f90: -------------------------------------------------------------------------------- 1 | module template_method_module 2 | 3 | implicit none 4 | private 5 | 6 | public :: otp_type, sms_type, email_type 7 | 8 | type, abstract :: iopt_type 9 | contains 10 | procedure(iopt_type_gen_random_opt), deferred :: gen_random_opt 11 | procedure(iopt_type_save_opt_cache), deferred :: save_opt_cache 12 | procedure(iopt_type_get_message), deferred :: get_message 13 | procedure(iopt_type_send_notification), deferred :: send_notification 14 | procedure(iopt_type_publish_metric), deferred :: publish_metric 15 | end type iopt_type 16 | 17 | abstract interface 18 | 19 | function iopt_type_gen_random_opt(self, len) result(random_opt) 20 | import iopt_type 21 | class(iopt_type), intent(inout) :: self 22 | integer, intent(in) :: len 23 | character(:), allocatable :: random_opt 24 | end function iopt_type_gen_random_opt 25 | 26 | subroutine iopt_type_save_opt_cache(self, otp) 27 | import iopt_type 28 | class(iopt_type), intent(inout) :: self 29 | character(*), intent(inout) :: otp 30 | end subroutine iopt_type_save_opt_cache 31 | 32 | function iopt_type_get_message(self, otp) result(msg) 33 | import iopt_type 34 | class(iopt_type), intent(inout) :: self 35 | character(*), intent(inout) :: otp 36 | character(:), allocatable :: msg 37 | end function iopt_type_get_message 38 | 39 | subroutine iopt_type_send_notification(self, msg) 40 | import iopt_type 41 | class(iopt_type), intent(inout) :: self 42 | character(*), intent(inout) :: msg 43 | end subroutine iopt_type_send_notification 44 | 45 | subroutine iopt_type_publish_metric(self) 46 | import iopt_type 47 | class(iopt_type), intent(inout) :: self 48 | end subroutine iopt_type_publish_metric 49 | 50 | end interface 51 | 52 | ! - - - - - - - - - - - - - 53 | 54 | type otp_type 55 | class(iopt_type), pointer :: iopt 56 | contains 57 | procedure :: gen_and_send_otp => otp_type_gen_and_send_otp 58 | end type otp_type 59 | 60 | type, extends(iopt_type) :: sms_type 61 | contains 62 | procedure :: gen_random_opt => sms_type_gen_random_opt 63 | procedure :: save_opt_cache => sms_type_save_opt_cache 64 | procedure :: get_message => sms_type_get_message 65 | procedure :: send_notification => sms_type_send_notification 66 | procedure :: publish_metric => sms_type_publish_metric 67 | end type sms_type 68 | 69 | type, extends(iopt_type) :: email_type 70 | contains 71 | procedure :: gen_random_opt => email_type_gen_random_opt 72 | procedure :: save_opt_cache => email_type_save_opt_cache 73 | procedure :: get_message => email_type_get_message 74 | procedure :: send_notification => email_type_send_notification 75 | procedure :: publish_metric => email_type_publish_metric 76 | end type email_type 77 | 78 | contains 79 | 80 | subroutine otp_type_gen_and_send_otp(self, otp_length) 81 | class(otp_type), intent(inout) :: self 82 | integer, intent(in) :: otp_length 83 | 84 | character(:), allocatable :: otp 85 | character(:), allocatable :: msg 86 | 87 | otp = self%iopt%gen_random_opt(otp_length) 88 | call self%iopt%save_opt_cache(otp) 89 | msg = self%iopt%get_message(otp) 90 | call self%iopt%send_notification(msg) 91 | call self%iopt%publish_metric() 92 | 93 | end subroutine otp_type_gen_and_send_otp 94 | 95 | ! - - - - - - - - - - 96 | 97 | function sms_type_gen_random_opt(self, len) result(random_opt) 98 | class(sms_type), intent(inout) :: self 99 | integer, intent(in) :: len 100 | character(:), allocatable :: random_opt 101 | 102 | random_opt = "1234" 103 | print *, "SMS: generating random otp ", random_opt 104 | 105 | end function sms_type_gen_random_opt 106 | 107 | subroutine sms_type_save_opt_cache(self, otp) 108 | class(sms_type), intent(inout) :: self 109 | character(*), intent(inout) :: otp 110 | 111 | print *, "SMS: saving otp: ", otp, " to cache" 112 | 113 | end subroutine sms_type_save_opt_cache 114 | 115 | function sms_type_get_message(self, otp) result(msg) 116 | class(sms_type), intent(inout) :: self 117 | character(*), intent(inout) :: otp 118 | character(:), allocatable :: msg 119 | 120 | msg = "SMS OTP for login is "//otp 121 | 122 | end function sms_type_get_message 123 | 124 | subroutine sms_type_send_notification(self, msg) 125 | class(sms_type), intent(inout) :: self 126 | character(*), intent(inout) :: msg 127 | 128 | print *, "SMS: sending sms: "//msg 129 | 130 | end subroutine sms_type_send_notification 131 | 132 | subroutine sms_type_publish_metric(self) 133 | class(sms_type), intent(inout) :: self 134 | 135 | print *, "SMS: publishing metric" 136 | 137 | end subroutine sms_type_publish_metric 138 | 139 | ! - - - - - - - - - - 140 | 141 | function email_type_gen_random_opt(self, len) result(random_opt) 142 | class(email_type), intent(inout) :: self 143 | integer, intent(in) :: len 144 | character(:), allocatable :: random_opt 145 | 146 | random_opt = "1234" 147 | print *, "EMAIL: generating random otp ", random_opt 148 | 149 | end function email_type_gen_random_opt 150 | 151 | subroutine email_type_save_opt_cache(self, otp) 152 | class(email_type), intent(inout) :: self 153 | character(*), intent(inout) :: otp 154 | 155 | print *, "EMAIL: saving otp: ", otp, " to cache" 156 | 157 | end subroutine email_type_save_opt_cache 158 | 159 | function email_type_get_message(self, otp) result(msg) 160 | class(email_type), intent(inout) :: self 161 | character(*), intent(inout) :: otp 162 | character(:), allocatable :: msg 163 | 164 | msg = "EMAIL OTP for login is "//otp 165 | 166 | end function email_type_get_message 167 | 168 | subroutine email_type_send_notification(self, msg) 169 | class(email_type), intent(inout) :: self 170 | character(*), intent(inout) :: msg 171 | 172 | print *, "EMAIL: sending email: "//msg 173 | 174 | end subroutine email_type_send_notification 175 | 176 | subroutine email_type_publish_metric(self) 177 | class(email_type), intent(inout) :: self 178 | 179 | print *, "EMAIL: publishing metric" 180 | 181 | end subroutine email_type_publish_metric 182 | 183 | end module template_method_module 184 | -------------------------------------------------------------------------------- /src/behavioral/visitor/visitor_main.f90: -------------------------------------------------------------------------------- 1 | !> Reference: https://refactoring.guru/design-patterns/visitor/go/example 2 | program test_visitor 3 | 4 | use visitor_pattern, only: square_type, circle_type, rectangle_type, area_calculator_type, middle_coordinates_type 5 | 6 | type(square_type) :: s = square_type(side=2) 7 | type(circle_type) :: c = circle_type(radius=3) 8 | type(rectangle_type) :: r = rectangle_type(l=2, b=3) 9 | 10 | type(area_calculator_type) :: a 11 | type(middle_coordinates_type) :: m 12 | 13 | !> area_calculator visiting shapes 14 | call s%accept(a) 15 | call c%accept(a) 16 | call r%accept(a) 17 | 18 | !> middle_coordinates visiting shapes 19 | call s%accept(m) 20 | call c%accept(m) 21 | call r%accept(m) 22 | 23 | !> Getting type of shape 24 | print *, s%get_type() 25 | print *, c%get_type() 26 | print *, r%get_type() 27 | 28 | end program test_visitor 29 | 30 | !> Results shall be: 31 | 32 | ! Calculating area for square.🔥 33 | ! Calculating area for circle.🔥 34 | ! Calculating area for rectangle.🔥 35 | ! Calculating middle point coordinates for square.💠 36 | ! Calculating middle point coordinates for circle.💠 37 | ! Calculating middle point coordinates for rectangle.💠 38 | ! Square 39 | ! Circle 40 | ! Rectangle -------------------------------------------------------------------------------- /src/behavioral/visitor/visitor_module.f90: -------------------------------------------------------------------------------- 1 | !> Reference: https://refactoring.guru/design-patterns/visitor/go/example 2 | module visitor_pattern 3 | 4 | implicit none 5 | private 6 | 7 | public :: square_type, circle_type, rectangle_type, area_calculator_type, middle_coordinates_type 8 | 9 | !> Two abstract classes 10 | 11 | type, abstract :: shape 12 | contains 13 | procedure(get_type_procedure), deferred :: get_type 14 | procedure(accept_procedure), deferred :: accept 15 | end type shape 16 | 17 | type, abstract :: visitor 18 | contains 19 | procedure(visit_procedure), deferred :: visit 20 | end type visitor 21 | 22 | abstract interface 23 | function get_type_procedure(self) result(result) 24 | import shape 25 | class(shape), intent(inout) :: self 26 | character(:), allocatable :: result 27 | end function get_type_procedure 28 | subroutine accept_procedure(self, v) 29 | import shape, visitor 30 | class(shape), intent(inout) :: self 31 | class(visitor), intent(inout) :: v 32 | end subroutine accept_procedure 33 | subroutine visit_procedure(self, s) 34 | import visitor, shape 35 | class(visitor), intent(inout) :: self 36 | class(shape), intent(inout) :: s 37 | end subroutine visit_procedure 38 | end interface 39 | 40 | !> Specific shapes 41 | 42 | type, extends(shape) :: square_type 43 | integer :: side 44 | contains 45 | procedure :: get_type => square_get_type 46 | procedure :: accept => square_accept 47 | end type square_type 48 | 49 | type, extends(shape) :: circle_type 50 | integer :: radius 51 | contains 52 | procedure :: get_type => circle_get_type 53 | procedure :: accept => circle_accept 54 | end type circle_type 55 | 56 | type, extends(shape) :: rectangle_type 57 | integer :: l 58 | integer :: b 59 | contains 60 | procedure :: get_type => rectangle_get_type 61 | procedure :: accept => rectangle_accept 62 | end type rectangle_type 63 | 64 | !> Specific visitors 65 | 66 | type, extends(visitor) :: area_calculator_type 67 | integer :: area 68 | contains 69 | procedure :: visit => area_calculator_visit 70 | end type area_calculator_type 71 | 72 | type, extends(visitor) :: middle_coordinates_type 73 | integer :: x, y 74 | contains 75 | procedure :: visit => middle_coordinates_visit 76 | end type middle_coordinates_type 77 | 78 | contains 79 | 80 | function square_get_type(self) result(result) 81 | class(square_type), intent(inout) :: self 82 | character(:), allocatable :: result 83 | result = "Square" 84 | end function square_get_type 85 | 86 | function circle_get_type(self) result(result) 87 | class(circle_type), intent(inout) :: self 88 | character(:), allocatable :: result 89 | result = "Circle" 90 | end function circle_get_type 91 | 92 | function rectangle_get_type(self) result(result) 93 | class(rectangle_type), intent(inout) :: self 94 | character(:), allocatable :: result 95 | result = "Rectangle" 96 | end function rectangle_get_type 97 | 98 | subroutine square_accept(self, v) 99 | class(square_type), intent(inout) :: self 100 | class(visitor), intent(inout) :: v 101 | call v%visit(self) 102 | end subroutine square_accept 103 | 104 | subroutine circle_accept(self, v) 105 | class(circle_type), intent(inout) :: self 106 | class(visitor), intent(inout) :: v 107 | call v%visit(self) 108 | end subroutine circle_accept 109 | 110 | subroutine rectangle_accept(self, v) 111 | class(rectangle_type), intent(inout) :: self 112 | class(visitor), intent(inout) :: v 113 | call v%visit(self) 114 | end subroutine rectangle_accept 115 | 116 | subroutine area_calculator_visit(self, s) 117 | class(area_calculator_type), intent(inout) :: self 118 | class(shape), intent(inout) :: s 119 | select type (s) 120 | type is (square_type) 121 | print *, "Calculating area for square.🔥" 122 | type is (circle_type) 123 | print *, "Calculating area for circle.🔥" 124 | type is (rectangle_type) 125 | print *, "Calculating area for rectangle.🔥" 126 | end select 127 | end subroutine area_calculator_visit 128 | 129 | subroutine middle_coordinates_visit(self, s) 130 | class(middle_coordinates_type), intent(inout) :: self 131 | class(shape), intent(inout) :: s 132 | select type (s) 133 | type is (square_type) 134 | print *, "Calculating middle point coordinates for square.💠" 135 | type is (circle_type) 136 | print *, "Calculating middle point coordinates for circle.💠" 137 | type is (rectangle_type) 138 | print *, "Calculating middle point coordinates for rectangle.💠" 139 | end select 140 | end subroutine middle_coordinates_visit 141 | 142 | end module visitor_pattern 143 | -------------------------------------------------------------------------------- /src/creational/abstract-factory/abstract_factory_main.f90: -------------------------------------------------------------------------------- 1 | program abstract_factory_main 2 | 3 | use, intrinsic :: iso_fortran_env, only: int8 4 | use abstract_factory_module, only: isports_factory_type, erke_type, lining_type, get_sports_factory, erke_shoe_type, & 5 | erke_shirt_type, lining_shoe_type, lining_shirt_type, ishoe_type, ishirt_type 6 | 7 | class(isports_factory_type), allocatable :: erke_factory, lining_factory 8 | class(ishoe_type), allocatable :: erke_shoe 9 | class(ishirt_type), allocatable :: erke_shirt 10 | class(ishoe_type), allocatable :: lining_shoe 11 | class(ishirt_type), allocatable :: lining_shirt 12 | 13 | ! allocate (erke_t :: erke_factory) 14 | ! allocate (lining_t :: lining_factory) 15 | 16 | erke_factory = get_sports_factory("erke") 17 | lining_factory = get_sports_factory("lining") 18 | 19 | ! allocate (erke_shoe_t :: erke_shoe) 20 | ! allocate (erke_shirt_t :: erke_shirt) 21 | ! allocate (lining_shoe_t :: lining_shoe) 22 | ! allocate (lining_shirt_t :: lining_shirt) 23 | 24 | erke_shoe = erke_factory%make_shoe() 25 | erke_shirt = erke_factory%make_shirt() 26 | 27 | lining_shoe = lining_factory%make_shoe() 28 | lining_shirt = lining_factory%make_shirt() 29 | 30 | call print_shoe_details(erke_shoe) 31 | call print_shirt_details(erke_shirt) 32 | 33 | call print_shoe_details(lining_shoe) 34 | call print_shirt_details(lining_shirt) 35 | 36 | contains 37 | 38 | subroutine print_shoe_details(ishoe) 39 | class(ishoe_type), intent(inout) :: ishoe 40 | 41 | print *, "This is a pair of shoes👟." 42 | print *, "Logo: ", ishoe%get_logo() 43 | print *, "Size: ", ishoe%get_size() 44 | 45 | end subroutine print_shoe_details 46 | 47 | subroutine print_shirt_details(ishirt) 48 | class(ishirt_type), intent(inout) :: ishirt 49 | 50 | print *, "This is a T-shirt👕." 51 | print *, "Logo: ", ishirt%get_logo() 52 | print *, "Size: ", ishirt%get_size() 53 | 54 | end subroutine print_shirt_details 55 | 56 | end program abstract_factory_main 57 | 58 | !> Results shall be: 59 | 60 | ! This is a pair of shoes👟. 61 | ! Logo: erke 62 | ! Size: 14 63 | ! This is a T-shirt👕. 64 | ! Logo: erke 65 | ! Size: 14 66 | ! This is a pair of shoes👟. 67 | ! Logo: lining 68 | ! Size: 14 69 | ! This is a T-shirt👕. 70 | ! Logo: lining 71 | ! Size: 14 -------------------------------------------------------------------------------- /src/creational/abstract-factory/abstract_factory_module.f90: -------------------------------------------------------------------------------- 1 | module abstract_factory_module 2 | 3 | use, intrinsic :: iso_fortran_env, only: int8 4 | implicit none 5 | private 6 | 7 | public :: isports_factory_type, erke_type, lining_type, get_sports_factory, erke_shoe_type, & 8 | erke_shirt_type, lining_shoe_type, lining_shirt_type, ishoe_type, ishirt_type 9 | 10 | !> Abstract classes 11 | type, abstract :: isports_factory_type 12 | contains 13 | procedure(isports_factory_type_make_shoe), deferred :: make_shoe 14 | procedure(isports_factory_type_make_shirt), deferred :: make_shirt 15 | end type isports_factory_type 16 | 17 | type, abstract :: ishoe_type 18 | contains 19 | procedure(ishoe_type_set_logo), deferred :: set_logo 20 | procedure(ishoe_type_set_size), deferred :: set_size 21 | procedure(ishoe_type_get_logo), deferred :: get_logo 22 | procedure(ishoe_type_get_size), deferred :: get_size 23 | end type ishoe_type 24 | 25 | type, abstract :: ishirt_type 26 | contains 27 | procedure(ishirt_type_set_logo), deferred :: set_logo 28 | procedure(ishirt_type_set_size), deferred :: set_size 29 | procedure(ishirt_type_get_logo), deferred :: get_logo 30 | procedure(ishirt_type_get_size), deferred :: get_size 31 | end type ishirt_type 32 | 33 | abstract interface 34 | 35 | function isports_factory_type_make_shoe(self) result(shoe) 36 | import isports_factory_type, ishoe_type 37 | class(isports_factory_type), intent(inout) :: self 38 | class(ishoe_type), allocatable :: shoe 39 | end function isports_factory_type_make_shoe 40 | function isports_factory_type_make_shirt(self) result(shirt) 41 | import isports_factory_type, ishirt_type 42 | class(isports_factory_type), intent(inout) :: self 43 | class(ishirt_type), allocatable :: shirt 44 | end function isports_factory_type_make_shirt 45 | 46 | subroutine ishoe_type_set_logo(self, logo) 47 | import ishoe_type 48 | class(ishoe_type), intent(inout) :: self 49 | character(*), intent(in) :: logo 50 | end subroutine ishoe_type_set_logo 51 | subroutine ishoe_type_set_size(self, size) 52 | import ishoe_type, int8 53 | class(ishoe_type), intent(inout) :: self 54 | integer(int8), intent(in) :: size 55 | end subroutine ishoe_type_set_size 56 | function ishoe_type_get_logo(self) result(logo) 57 | import ishoe_type 58 | class(ishoe_type), intent(inout) :: self 59 | character(:), allocatable :: logo 60 | end function ishoe_type_get_logo 61 | function ishoe_type_get_size(self) result(size) 62 | import ishoe_type, int8 63 | class(ishoe_type), intent(inout) :: self 64 | integer(int8) :: size 65 | end function ishoe_type_get_size 66 | 67 | subroutine ishirt_type_set_logo(self, logo) 68 | import ishirt_type 69 | class(ishirt_type), intent(inout) :: self 70 | character(*), intent(in) :: logo 71 | end subroutine ishirt_type_set_logo 72 | subroutine ishirt_type_set_size(self, size) 73 | import ishirt_type, int8 74 | class(ishirt_type), intent(inout) :: self 75 | integer(int8), intent(in) :: size 76 | end subroutine ishirt_type_set_size 77 | function ishirt_type_get_logo(self) result(logo) 78 | import ishirt_type 79 | class(ishirt_type), intent(inout) :: self 80 | character(:), allocatable :: logo 81 | end function ishirt_type_get_logo 82 | function ishirt_type_get_size(self) result(size) 83 | import ishirt_type, int8 84 | class(ishirt_type), intent(inout) :: self 85 | integer(int8) :: size 86 | end function ishirt_type_get_size 87 | 88 | end interface 89 | 90 | !> Specific objects 91 | 92 | type, extends(isports_factory_type) :: erke_type 93 | contains 94 | procedure :: make_shoe => erke_type_make_shoe 95 | procedure :: make_shirt => erke_type_make_shirt 96 | end type erke_type 97 | 98 | type, extends(isports_factory_type) :: lining_type 99 | contains 100 | procedure :: make_shoe => lining_type_make_shoe 101 | procedure :: make_shirt => lining_type_make_shirt 102 | end type lining_type 103 | 104 | type, extends(ishoe_type) :: shoe_type 105 | character(:), allocatable :: logo 106 | integer(int8) :: size 107 | contains 108 | procedure :: set_logo => shoe_type_set_logo 109 | procedure :: set_size => shoe_type_set_size 110 | procedure :: get_logo => shoe_type_get_logo 111 | procedure :: get_size => shoe_type_get_size 112 | end type shoe_type 113 | 114 | type, extends(ishirt_type) :: shirt_type 115 | character(:), allocatable :: logo 116 | integer(int8) :: size 117 | contains 118 | procedure :: set_logo => shirt_type_set_logo 119 | procedure :: set_size => shirt_type_set_size 120 | procedure :: get_logo => shirt_type_get_logo 121 | procedure :: get_size => shirt_type_get_size 122 | end type shirt_type 123 | 124 | type, extends(shoe_type) :: erke_shoe_type 125 | end type erke_shoe_type 126 | 127 | type, extends(shoe_type) :: lining_shoe_type 128 | end type lining_shoe_type 129 | 130 | type, extends(shirt_type) :: erke_shirt_type 131 | end type erke_shirt_type 132 | 133 | type, extends(shirt_type) :: lining_shirt_type 134 | end type lining_shirt_type 135 | 136 | contains 137 | 138 | function get_sports_factory(brand) result(isports_factory) 139 | character(*), intent(in) :: brand 140 | class(isports_factory_type), allocatable :: isports_factory 141 | 142 | select case (brand) 143 | case ("erke") 144 | isports_factory = erke_type() 145 | case ("lining") 146 | isports_factory = lining_type() 147 | case default 148 | error stop "** Brand not supported." 149 | end select 150 | 151 | end function get_sports_factory 152 | 153 | function erke_type_make_shoe(self) result(shoe) 154 | class(erke_type), intent(inout) :: self 155 | class(ishoe_type), allocatable :: shoe 156 | 157 | shoe = erke_shoe_type(logo="erke", size=15_int8) 158 | 159 | end function erke_type_make_shoe 160 | 161 | function erke_type_make_shirt(self) result(shirt) 162 | class(erke_type), intent(inout) :: self 163 | class(ishirt_type), allocatable :: shirt 164 | 165 | shirt = erke_shirt_type(logo="erke", size=84_int8) 166 | 167 | end function erke_type_make_shirt 168 | 169 | function lining_type_make_shoe(self) result(shoe) 170 | class(lining_type), intent(inout) :: self 171 | class(ishoe_type), allocatable :: shoe 172 | 173 | shoe = lining_shoe_type(logo="lining", size=14_int8) 174 | 175 | end function lining_type_make_shoe 176 | 177 | function lining_type_make_shirt(self) result(shirt) 178 | class(lining_type), intent(inout) :: self 179 | class(ishirt_type), allocatable :: shirt 180 | 181 | shirt = lining_shirt_type(logo="lining", size=85_int8) 182 | 183 | end function lining_type_make_shirt 184 | 185 | subroutine shoe_type_set_logo(self, logo) 186 | class(shoe_type), intent(inout) :: self 187 | character(*), intent(in) :: logo 188 | 189 | self%logo = logo 190 | 191 | end subroutine shoe_type_set_logo 192 | 193 | subroutine shoe_type_set_size(self, size) 194 | class(shoe_type), intent(inout) :: self 195 | integer(int8), intent(in) :: size 196 | 197 | self%size = size 198 | 199 | end subroutine shoe_type_set_size 200 | 201 | function shoe_type_get_logo(self) result(logo) 202 | class(shoe_type), intent(inout) :: self 203 | character(:), allocatable :: logo 204 | 205 | logo = self%logo 206 | 207 | end function shoe_type_get_logo 208 | 209 | function shoe_type_get_size(self) result(size) 210 | class(shoe_type), intent(inout) :: self 211 | integer(int8) :: size 212 | 213 | size = self%size 214 | 215 | end function shoe_type_get_size 216 | 217 | subroutine shirt_type_set_logo(self, logo) 218 | class(shirt_type), intent(inout) :: self 219 | character(*), intent(in) :: logo 220 | 221 | self%logo = logo 222 | 223 | end subroutine shirt_type_set_logo 224 | 225 | subroutine shirt_type_set_size(self, size) 226 | class(shirt_type), intent(inout) :: self 227 | integer(int8), intent(in) :: size 228 | 229 | self%size = size 230 | 231 | end subroutine shirt_type_set_size 232 | 233 | function shirt_type_get_logo(self) result(logo) 234 | class(shirt_type), intent(inout) :: self 235 | character(:), allocatable :: logo 236 | 237 | logo = self%logo 238 | 239 | end function shirt_type_get_logo 240 | 241 | function shirt_type_get_size(self) result(size) 242 | class(shirt_type), intent(inout) :: self 243 | integer(int8) :: size 244 | 245 | size = self%size 246 | 247 | end function shirt_type_get_size 248 | 249 | end module abstract_factory_module 250 | -------------------------------------------------------------------------------- /src/creational/builder/builder_main.f90: -------------------------------------------------------------------------------- 1 | program builder_main 2 | use builder_module, only: ibuilder_type, director_type, house_type, get_builder 3 | implicit none 4 | 5 | class(ibuilder_type), allocatable :: normal_builder, igloo_builder 6 | type(director_type) :: director 7 | type(house_type) :: normal_house, igloo_house 8 | 9 | normal_builder = get_builder("normal") 10 | igloo_builder = get_builder("igloo") 11 | 12 | !> Normal House 13 | call director%set_builder(normal_builder) 14 | normal_house = director%build_house() 15 | 16 | print *, "Normal House Door Type: ", normal_house%door_type 17 | print *, "Normal House Window Type: ", normal_house%window_type 18 | print *, "Normal House Num Floor: ", normal_house%floor 19 | 20 | !> Igloo House 21 | call director%set_builder(igloo_builder) 22 | igloo_house = director%build_house() 23 | 24 | print *, "Igloo House Door Type: ", igloo_house%door_type 25 | print *, "Igloo House Window Type: ", igloo_house%window_type 26 | print *, "Igloo House Num Floor: ", igloo_house%floor 27 | 28 | end program builder_main 29 | 30 | !> Results shall be: 31 | 32 | ! Normal House Door Type: Wooden Door 33 | ! Normal House Window Type: Wooden Window 34 | ! Normal House Num Floor: 2 35 | ! Igloo House Door Type: Snow Door 36 | ! Igloo House Window Type: Snow Window 37 | ! Igloo House Num Floor: 1 -------------------------------------------------------------------------------- /src/creational/builder/builder_module.f90: -------------------------------------------------------------------------------- 1 | module builder_module 2 | 3 | use, intrinsic :: iso_fortran_env, only: int8 4 | implicit none 5 | private 6 | 7 | public :: ibuilder_type, director_type, house_type, get_builder 8 | 9 | type, abstract :: ibuilder_type 10 | contains 11 | procedure(ibuilder_type_set_window_type), deferred :: set_window_type 12 | procedure(ibuilder_type_set_door_type), deferred :: set_door_type 13 | procedure(ibuilder_type_set_num_floor), deferred :: set_num_floor 14 | procedure(ibuilder_type_get_house), deferred :: get_house 15 | end type ibuilder_type 16 | 17 | type, extends(ibuilder_type) :: normal_builder_type 18 | character(:), allocatable :: window_type 19 | character(:), allocatable :: door_type 20 | integer(int8) :: floor 21 | contains 22 | procedure :: set_window_type => normal_builder_type_set_window_type 23 | procedure :: set_door_type => normal_builder_type_set_door_type 24 | procedure :: set_num_floor => normal_builder_type_set_num_floor 25 | procedure :: get_house => normal_builder_type_get_house 26 | end type normal_builder_type 27 | 28 | type, extends(ibuilder_type) :: igloo_builder_type 29 | character(:), allocatable :: window_type 30 | character(:), allocatable :: door_type 31 | integer(int8) :: floor 32 | contains 33 | procedure :: set_window_type => igloo_builder_type_set_window_type 34 | procedure :: set_door_type => igloo_builder_type_set_door_type 35 | procedure :: set_num_floor => igloo_builder_type_set_num_floor 36 | procedure :: get_house => igloo_builder_type_get_house 37 | end type igloo_builder_type 38 | 39 | type house_type 40 | character(:), allocatable :: window_type 41 | character(:), allocatable :: door_type 42 | integer(int8) :: floor 43 | end type house_type 44 | 45 | type director_type 46 | class(ibuilder_type), pointer :: builder 47 | contains 48 | procedure :: set_builder => director_type_set_builder 49 | procedure :: build_house => director_type_build_house 50 | end type director_type 51 | 52 | abstract interface 53 | 54 | subroutine ibuilder_type_set_window_type(self) 55 | import ibuilder_type 56 | class(ibuilder_type), intent(inout) :: self 57 | end subroutine ibuilder_type_set_window_type 58 | 59 | subroutine ibuilder_type_set_door_type(self) 60 | import ibuilder_type 61 | class(ibuilder_type), intent(inout) :: self 62 | end subroutine ibuilder_type_set_door_type 63 | 64 | subroutine ibuilder_type_set_num_floor(self) 65 | import ibuilder_type 66 | class(ibuilder_type), intent(inout) :: self 67 | end subroutine ibuilder_type_set_num_floor 68 | 69 | function ibuilder_type_get_house(self) result(house) 70 | import ibuilder_type, house_type 71 | class(ibuilder_type), intent(inout) :: self 72 | type(house_type) :: house 73 | end function ibuilder_type_get_house 74 | 75 | end interface 76 | 77 | contains 78 | 79 | function get_builder(builder_type) result(ibuilder) 80 | character(*), intent(in) :: builder_type 81 | class(ibuilder_type), allocatable :: ibuilder 82 | select case (builder_type) 83 | case ("normal") 84 | allocate (normal_builder_type :: ibuilder) 85 | case ("igloo") 86 | allocate (igloo_builder_type :: ibuilder) 87 | end select 88 | end function get_builder 89 | 90 | ! - - - - - - - - - - 91 | 92 | subroutine normal_builder_type_set_window_type(self) 93 | class(normal_builder_type), intent(inout) :: self 94 | self%window_type = "Wooden Window" 95 | end subroutine normal_builder_type_set_window_type 96 | 97 | subroutine normal_builder_type_set_door_type(self) 98 | class(normal_builder_type), intent(inout) :: self 99 | self%door_type = "Wooden Door" 100 | end subroutine normal_builder_type_set_door_type 101 | 102 | subroutine normal_builder_type_set_num_floor(self) 103 | class(normal_builder_type), intent(inout) :: self 104 | self%floor = 2_int8 105 | end subroutine normal_builder_type_set_num_floor 106 | 107 | function normal_builder_type_get_house(self) result(house) 108 | class(normal_builder_type), intent(inout) :: self 109 | type(house_type) :: house 110 | ! TODO: A GFortran Bug Here. 111 | ! house = house_t(door_type=self%door_type, & 112 | ! window_type=self%window_type, & 113 | ! floor=self%floor) 114 | house%door_type = self%door_type 115 | house%window_type = self%window_type 116 | house%floor = self%floor 117 | end function normal_builder_type_get_house 118 | 119 | ! - - - - - - - - - - 120 | 121 | subroutine igloo_builder_type_set_window_type(self) 122 | class(igloo_builder_type), intent(inout) :: self 123 | self%window_type = "Snow Window" 124 | end subroutine igloo_builder_type_set_window_type 125 | 126 | subroutine igloo_builder_type_set_door_type(self) 127 | class(igloo_builder_type), intent(inout) :: self 128 | self%door_type = "Snow Door" 129 | end subroutine igloo_builder_type_set_door_type 130 | 131 | subroutine igloo_builder_type_set_num_floor(self) 132 | class(igloo_builder_type), intent(inout) :: self 133 | self%floor = 1_int8 134 | end subroutine igloo_builder_type_set_num_floor 135 | 136 | function igloo_builder_type_get_house(self) result(house) 137 | class(igloo_builder_type), intent(inout) :: self 138 | type(house_type) :: house 139 | ! house = house_t(door_type=self%door_type, & 140 | ! window_type=self%window_type, & 141 | ! floor=self%floor) 142 | house%door_type = self%door_type 143 | house%window_type = self%window_type 144 | house%floor = self%floor 145 | end function igloo_builder_type_get_house 146 | 147 | ! - - - - - - - - - - 148 | 149 | subroutine director_type_set_builder(self, b) 150 | class(director_type), intent(inout) :: self 151 | class(ibuilder_type), intent(inout), target :: b 152 | self%builder => b 153 | end subroutine director_type_set_builder 154 | 155 | function director_type_build_house(self) result(house) 156 | class(director_type), intent(inout) :: self 157 | type(house_type) :: house 158 | call self%builder%set_door_type() 159 | call self%builder%set_window_type() 160 | call self%builder%set_num_floor() 161 | house = self%builder%get_house() 162 | end function director_type_build_house 163 | 164 | end module builder_module 165 | -------------------------------------------------------------------------------- /src/creational/factory/factory_main.f90: -------------------------------------------------------------------------------- 1 | program factory_main 2 | 3 | use factory_module, only: igun_type, ak47_type, musket_type, get_gun 4 | implicit none 5 | 6 | class(igun_type), allocatable :: ak47, musket 7 | 8 | allocate (ak47_type :: ak47) 9 | allocate (musket_type :: musket) 10 | 11 | ak47 = get_gun("ak47") 12 | musket = get_gun("musket") 13 | 14 | call print_details(ak47) 15 | call print_details(musket) 16 | 17 | contains 18 | 19 | subroutine print_details(igun) 20 | class(igun_type), intent(inout) :: igun 21 | print *, "Gun: ", igun%get_name() 22 | print *, "Power: ", igun%get_power() 23 | end subroutine print_details 24 | 25 | end program factory_main 26 | 27 | !> Results shall be: 28 | 29 | ! Gun: ak47 gun 30 | ! Power: 4 31 | ! Gun: musket gun 32 | ! Power: 1 -------------------------------------------------------------------------------- /src/creational/factory/factory_module.f90: -------------------------------------------------------------------------------- 1 | module factory_module 2 | 3 | use, intrinsic :: iso_fortran_env, only: int8 4 | implicit none 5 | private 6 | 7 | public :: igun_type, ak47_type, musket_type, get_gun 8 | 9 | type, abstract :: igun_type 10 | contains 11 | procedure(igun_type_set_name), deferred :: set_name 12 | procedure(igun_type_set_power), deferred :: set_power 13 | procedure(igun_type_get_name), deferred :: get_name 14 | procedure(igun_type_get_power), deferred :: get_power 15 | end type igun_type 16 | 17 | abstract interface 18 | 19 | subroutine igun_type_set_name(self, name) 20 | import igun_type 21 | class(igun_type), intent(inout) :: self 22 | character(*), intent(in) :: name 23 | end subroutine igun_type_set_name 24 | 25 | subroutine igun_type_set_power(self, power) 26 | import igun_type, int8 27 | class(igun_type), intent(inout) :: self 28 | integer(int8), intent(in) :: power 29 | end subroutine igun_type_set_power 30 | 31 | function igun_type_get_name(self) result(name) 32 | import igun_type 33 | class(igun_type), intent(inout) :: self 34 | character(:), allocatable :: name 35 | end function igun_type_get_name 36 | 37 | function igun_type_get_power(self) result(power) 38 | import igun_type, int8 39 | class(igun_type), intent(inout) :: self 40 | integer(int8) :: power 41 | end function igun_type_get_power 42 | 43 | end interface 44 | 45 | type, extends(igun_type) :: gun_type 46 | character(:), allocatable :: name 47 | integer(int8) :: power 48 | contains 49 | procedure :: set_name => gun_type_set_name 50 | procedure :: get_name => gun_type_get_name 51 | procedure :: set_power => gun_type_set_power 52 | procedure :: get_power => gun_type_get_power 53 | end type gun_type 54 | 55 | type, extends(gun_type) :: ak47_type 56 | end type ak47_type 57 | 58 | type, extends(gun_type) :: musket_type 59 | end type musket_type 60 | 61 | contains 62 | 63 | subroutine gun_type_set_name(self, name) 64 | class(gun_type), intent(inout) :: self 65 | character(*), intent(in) :: name 66 | self%name = name 67 | end subroutine gun_type_set_name 68 | 69 | subroutine gun_type_set_power(self, power) 70 | class(gun_type), intent(inout) :: self 71 | integer(int8), intent(in) :: power 72 | self%power = power 73 | end subroutine gun_type_set_power 74 | 75 | function gun_type_get_name(self) result(name) 76 | class(gun_type), intent(inout) :: self 77 | character(:), allocatable :: name 78 | name = self%name 79 | end function gun_type_get_name 80 | 81 | function gun_type_get_power(self) result(power) 82 | class(gun_type), intent(inout) :: self 83 | integer(int8) :: power 84 | power = self%power 85 | end function gun_type_get_power 86 | 87 | function get_gun(gun_type) result(igun) 88 | character(*), intent(in) :: gun_type 89 | class(igun_type), allocatable :: igun 90 | 91 | select case (gun_type) 92 | case ("ak47") 93 | igun = ak47_type(name="ak47 gun", power=4) 94 | case ("musket") 95 | igun = musket_type(name="musket gun", power=1) 96 | case default 97 | error stop "*ERROR* `gnu_type` not supported" 98 | end select 99 | 100 | end function get_gun 101 | 102 | end module factory_module 103 | -------------------------------------------------------------------------------- /src/creational/prototype/prototype_main.f90: -------------------------------------------------------------------------------- 1 | program prototype_main 2 | use prototype_module, only: file_type, folder_type, inode_type 3 | implicit none 4 | type(file_type), target :: file1, file2, file3 5 | type(folder_type), target :: folder1 6 | type(folder_type) :: folder2 7 | class(inode_type), allocatable :: clone_folder 8 | 9 | file1%name = "file1" 10 | file2%name = "file2" 11 | file3%name = "file3" 12 | 13 | folder1%name = "folder1" 14 | allocate (folder1%children(1)) 15 | folder1%children(1)%inode => file1 16 | 17 | folder2%name = "folder2" 18 | allocate (folder2%children(3)) 19 | folder2%children(1)%inode => folder1 20 | folder2%children(2)%inode => file2 21 | folder2%children(3)%inode => file3 22 | 23 | print *, "Printing hierarchy for Folder2" 24 | call folder2%print(" ") 25 | 26 | clone_folder = folder2%clone() 27 | print *, "Printing hierarchy for clone Folder" 28 | call clone_folder%print(" ") 29 | 30 | end program prototype_main 31 | 32 | !> Results shall be: 33 | 34 | ! Printing hierarchy for Folder2 35 | ! folder2 36 | ! folder1 37 | ! file1 38 | ! file2 39 | ! file3 40 | ! Printing hierarchy for clone Folder 41 | ! folder2_clone 42 | ! folder1_clone 43 | ! file1_clone 44 | ! file2_clone 45 | ! file3_clone -------------------------------------------------------------------------------- /src/creational/prototype/prototype_module.f90: -------------------------------------------------------------------------------- 1 | module prototype_module 2 | 3 | implicit none 4 | private 5 | 6 | public :: file_type, folder_type, inode_type 7 | 8 | type, abstract :: inode_type 9 | contains 10 | procedure(inode_type_print), deferred :: print 11 | procedure(inode_type_clone), deferred :: clone 12 | end type inode_type 13 | 14 | type, extends(inode_type) :: file_type 15 | character(:), allocatable :: name 16 | contains 17 | procedure :: print => file_type_print 18 | procedure :: clone => file_type_clone 19 | end type file_type 20 | 21 | !> Wrapper (Important) 22 | type node_type 23 | class(inode_type), pointer :: inode 24 | end type node_type 25 | 26 | type, extends(inode_type) :: folder_type 27 | type(node_type), allocatable :: children(:) 28 | character(:), allocatable :: name 29 | contains 30 | procedure :: print => folder_type_print 31 | procedure :: clone => folder_type_clone 32 | end type folder_type 33 | 34 | abstract interface 35 | 36 | subroutine inode_type_print(self, indentation) 37 | import inode_type 38 | class(inode_type), intent(inout) :: self 39 | character(*), intent(in) :: indentation 40 | end subroutine inode_type_print 41 | 42 | function inode_type_clone(self) result(inode) 43 | import inode_type 44 | class(inode_type), intent(inout) :: self 45 | class(inode_type), allocatable :: inode 46 | end function inode_type_clone 47 | 48 | end interface 49 | 50 | contains 51 | 52 | subroutine file_type_print(self, indentation) 53 | class(file_type), intent(inout) :: self 54 | character(*), intent(in) :: indentation 55 | print *, indentation//self%name 56 | end subroutine file_type_print 57 | 58 | function file_type_clone(self) result(inode) 59 | class(file_type), intent(inout) :: self 60 | class(inode_type), allocatable :: inode 61 | allocate (file_type :: inode) 62 | inode = file_type(name=self%name//"_clone") 63 | end function file_type_clone 64 | 65 | ! - - - - - - - - - 66 | 67 | subroutine folder_type_print(self, indentation) 68 | class(folder_type), intent(inout) :: self 69 | character(*), intent(in) :: indentation 70 | integer :: i 71 | print *, indentation//self%name 72 | if (size(self%children) == 0) return 73 | do i = 1, size(self%children) 74 | call self%children(i)%inode%print(indentation//indentation) 75 | end do 76 | end subroutine folder_type_print 77 | 78 | !> There may be incorrect usage here, but I have no choice but to do so. 79 | !> Fortran's compilation check is stricter, and I am indeed bypassing it. 80 | function folder_type_clone(self) result(inode) 81 | class(folder_type), intent(inout) :: self 82 | class(inode_type), allocatable :: inode 83 | type(folder_type), allocatable :: tmp_folder 84 | integer :: i 85 | allocate (tmp_folder, source=self) 86 | tmp_folder%name = tmp_folder%name//"_clone" 87 | if (size(self%children) > 0) then 88 | do i = 1, size(tmp_folder%children) 89 | associate (node => tmp_folder%children(i)%inode) 90 | inode = node%clone() 91 | allocate (tmp_folder%children(i)%inode, source=inode) 92 | end associate 93 | end do 94 | end if 95 | 96 | call move_alloc(tmp_folder, inode) 97 | end function folder_type_clone 98 | 99 | end module prototype_module 100 | -------------------------------------------------------------------------------- /src/creational/singleton/singleton_main.f90: -------------------------------------------------------------------------------- 1 | program singleton_main 2 | 3 | use singleton_module, only: single, get_instance, dispose_instance 4 | implicit none 5 | 6 | single = get_instance(10) 7 | single = get_instance(23) 8 | single = get_instance(0) 9 | call dispose_instance(single) 10 | single = get_instance(9) 11 | 12 | end program singleton_main 13 | -------------------------------------------------------------------------------- /src/creational/singleton/singleton_module.f90: -------------------------------------------------------------------------------- 1 | module singleton_module 2 | 3 | implicit none 4 | private 5 | 6 | public :: single, get_instance, dispose_instance 7 | 8 | logical :: lock = .false. 9 | 10 | type single_type 11 | private 12 | integer :: value 13 | end type single_type 14 | 15 | type(single_type) :: single 16 | 17 | contains 18 | 19 | function get_instance(value) result(single) 20 | integer, intent(in) :: value 21 | type(single_type) :: single 22 | if (lock) then 23 | print *, "Single instance already created." 24 | return 25 | else 26 | print *, "Creating single instance now." 27 | single%value = value 28 | lock = .true. 29 | end if 30 | end function get_instance 31 | 32 | subroutine dispose_instance(single) 33 | type(single_type), intent(inout) :: single 34 | print *, "Disposing single instance now." 35 | single%value = 0 36 | lock = .false. 37 | end subroutine dispose_instance 38 | 39 | end module singleton_module 40 | -------------------------------------------------------------------------------- /src/others/interface-limit/interface_limit_main.f90: -------------------------------------------------------------------------------- 1 | program interface_limit_main 2 | 3 | use interface_limit_module, only: circle_type, square_type, cs_interact 4 | implicit none 5 | type(circle_type) :: c1 6 | type(square_type) :: s1 7 | 8 | call cs_interact(c1, s1) 9 | 10 | end program interface_limit_main 11 | -------------------------------------------------------------------------------- /src/others/interface-limit/interface_limit_module.f90: -------------------------------------------------------------------------------- 1 | !> @note Because fortran's interfaces are static, it is difficult to implement dynamic binding, 2 | !> which restricts abstract classes from being fully functional or interacting with each other in a way that is not flexible; 3 | !> instead, it would be more practical to use non-procedural binding. 4 | module interface_limit_module 5 | 6 | implicit none 7 | 8 | private 9 | public :: circle_type, square_type, shape_type, cs_interact 10 | 11 | type, abstract :: shape_type 12 | end type shape_type 13 | 14 | abstract interface 15 | subroutine interact(shape1, shape2) 16 | import :: shape_type 17 | class(shape_type), intent(inout) :: shape1, shape2 18 | end subroutine interact 19 | end interface 20 | 21 | type, extends(shape_type) :: circle_type 22 | end type circle_type 23 | 24 | type, extends(shape_type) :: square_type 25 | end type square_type 26 | 27 | contains 28 | 29 | !> @note This is a non-procedural binding, which is more flexible than procedural binding when it have to comes to dynamic binding. 30 | subroutine cs_interact(cir, squ) 31 | type(circle_type), intent(inout) :: cir 32 | type(square_type), intent(inout) :: squ 33 | 34 | print *, "circle-square interaction" 35 | 36 | end subroutine cs_interact 37 | 38 | end module interface_limit_module 39 | -------------------------------------------------------------------------------- /src/others/interface-specific/interface_specific_main.f90: -------------------------------------------------------------------------------- 1 | !> @note use `select type` is a limited form of polymorphism 2 | program interface_specific_main 3 | 4 | use interface_specific_module, only: shape_type, circle_type, print_circle 5 | implicit none 6 | class(shape_type), allocatable :: s1 7 | 8 | allocate (circle_type :: s1) 9 | 10 | select type (s1) 11 | type is (circle_type) 12 | call print_circle(s1) 13 | end select 14 | 15 | end program interface_specific_main 16 | -------------------------------------------------------------------------------- /src/others/interface-specific/interface_specific_module.f90: -------------------------------------------------------------------------------- 1 | module interface_specific_module 2 | 3 | implicit none 4 | 5 | private 6 | public :: shape_type, circle_type, print_circle 7 | 8 | type, abstract :: shape_type 9 | end type shape_type 10 | 11 | type, extends(shape_type) :: circle_type 12 | end type circle_type 13 | 14 | contains 15 | 16 | !> print circle 17 | subroutine print_circle(this) 18 | type(circle_type), intent(in) :: this 19 | 20 | print *, 'circle' 21 | 22 | end subroutine print_circle 23 | 24 | end module interface_specific_module 25 | -------------------------------------------------------------------------------- /src/structural/adapter/adapter_main.f90: -------------------------------------------------------------------------------- 1 | program adapter_main 2 | use adapter_module, only: client_type, computer_type, mac_type, windows_type, windows_adapter_type 3 | implicit none 4 | type(client_type) :: client 5 | type(mac_type) :: mac 6 | type(windows_type), target :: windows 7 | type(windows_adapter_type) :: windows_adapter 8 | 9 | call client%insert_lightning_connector_into_computer(mac) 10 | windows_adapter%windows_machine => windows 11 | call client%insert_lightning_connector_into_computer(windows_adapter) 12 | 13 | end program adapter_main 14 | 15 | !> Results shall be: 16 | 17 | ! Client inserts Lightning connector into computer. 18 | ! Lightning connector is plugged into mac machine. 19 | ! Client inserts Lightning connector into computer. 20 | ! Adapter converts Lightning signal to USB. 21 | ! USB connector is plugged into windows machine. -------------------------------------------------------------------------------- /src/structural/adapter/adapter_module.f90: -------------------------------------------------------------------------------- 1 | module adapter_module 2 | 3 | implicit none 4 | private 5 | 6 | public :: client_type, computer_type, mac_type, windows_type, windows_adapter_type 7 | 8 | type client_type 9 | contains 10 | procedure :: insert_lightning_connector_into_computer => client_type_insert_lightning_connector_into_computer 11 | end type client_type 12 | 13 | type, abstract :: computer_type 14 | contains 15 | procedure(computer_type_insert_into_lightning_port), deferred :: insert_into_lightning_port 16 | end type computer_type 17 | 18 | type, extends(computer_type) :: mac_type 19 | contains 20 | procedure :: insert_into_lightning_port => mac_type_insert_into_lightning_port 21 | end type mac_type 22 | 23 | type, extends(computer_type) :: windows_type 24 | contains 25 | procedure :: insert_into_lightning_port => windows_type_insert_into_lightning_port 26 | end type windows_type 27 | 28 | type, extends(computer_type) :: windows_adapter_type 29 | type(windows_type), pointer :: windows_machine 30 | contains 31 | procedure :: insert_into_lightning_port => windows_adapter_type_insert_into_lightning_port 32 | end type windows_adapter_type 33 | 34 | abstract interface 35 | subroutine computer_type_insert_into_lightning_port(self) 36 | import computer_type 37 | class(computer_type), intent(inout) :: self 38 | end subroutine computer_type_insert_into_lightning_port 39 | end interface 40 | 41 | contains 42 | 43 | subroutine client_type_insert_lightning_connector_into_computer(self, com) 44 | class(client_type), intent(inout) :: self 45 | class(computer_type), intent(inout) :: com 46 | print *, "Client inserts Lightning connector into computer." 47 | call com%insert_into_lightning_port() 48 | end subroutine client_type_insert_lightning_connector_into_computer 49 | 50 | subroutine mac_type_insert_into_lightning_port(self) 51 | class(mac_type), intent(inout) :: self 52 | print *, "Lightning connector is plugged into mac machine." 53 | end subroutine mac_type_insert_into_lightning_port 54 | 55 | subroutine windows_type_insert_into_lightning_port(self) 56 | class(windows_type), intent(inout) :: self 57 | print *, "USB connector is plugged into windows machine." 58 | end subroutine windows_type_insert_into_lightning_port 59 | 60 | subroutine windows_adapter_type_insert_into_lightning_port(self) 61 | class(windows_adapter_type), intent(inout) :: self 62 | print *, "Adapter converts Lightning signal to USB." 63 | call self%windows_machine%insert_into_lightning_port() 64 | end subroutine windows_adapter_type_insert_into_lightning_port 65 | 66 | end module adapter_module 67 | -------------------------------------------------------------------------------- /src/structural/bridge/bridge_main.f90: -------------------------------------------------------------------------------- 1 | program bridge_main 2 | 3 | use bridge_module, only: hp_type, epson_type, mac_type, windows_type 4 | implicit none 5 | 6 | type(hp_type) :: hp_printer 7 | type(epson_type) :: epson_printer 8 | type(mac_type) :: mac_computer 9 | type(windows_type) :: windows_computer 10 | 11 | call mac_computer%set_printer(hp_printer) 12 | call mac_computer%print() 13 | 14 | call mac_computer%set_printer(epson_printer) 15 | call mac_computer%print() 16 | 17 | call windows_computer%set_printer(hp_printer) 18 | call windows_computer%print() 19 | 20 | call windows_computer%set_printer(epson_printer) 21 | call windows_computer%print() 22 | 23 | end program bridge_main 24 | 25 | !> Results shall be: 26 | 27 | ! Print request for mac 28 | ! Printing by a HP Printer 29 | ! Print request for mac 30 | ! Printing by a EPSON Printer 31 | ! Print request for windows 32 | ! Printing by a HP Printer 33 | ! Print request for windows 34 | ! Printing by a EPSON Printer -------------------------------------------------------------------------------- /src/structural/bridge/bridge_module.f90: -------------------------------------------------------------------------------- 1 | module bridge_module 2 | 3 | implicit none 4 | private 5 | 6 | public :: hp_type, epson_type, mac_type, windows_type 7 | 8 | type, abstract :: computer_type 9 | contains 10 | procedure(computer_type_print), deferred :: print 11 | procedure(computer_type_set_printer), deferred :: set_printer 12 | end type computer_type 13 | 14 | type, abstract :: printer_type 15 | contains 16 | procedure(printer_type_print_file), deferred :: print_file 17 | end type printer_type 18 | 19 | abstract interface 20 | 21 | subroutine computer_type_print(self) 22 | import computer_type 23 | class(computer_type), intent(inout) :: self 24 | end subroutine computer_type_print 25 | 26 | subroutine computer_type_set_printer(self, printer) 27 | import computer_type, printer_type 28 | class(computer_type), intent(inout) :: self 29 | class(printer_type), intent(inout), target :: printer 30 | end subroutine computer_type_set_printer 31 | 32 | subroutine printer_type_print_file(self) 33 | import printer_type 34 | class(printer_type), intent(inout) :: self 35 | end subroutine printer_type_print_file 36 | 37 | end interface 38 | 39 | type, extends(printer_type) :: epson_type 40 | contains 41 | procedure :: print_file => epson_type_print_file 42 | end type epson_type 43 | 44 | type, extends(printer_type) :: hp_type 45 | contains 46 | procedure :: print_file => hp_type_print_file 47 | end type hp_type 48 | 49 | type, extends(computer_type) :: mac_type 50 | class(printer_type), pointer :: printer 51 | contains 52 | procedure :: print => mac_type_print 53 | procedure :: set_printer => mac_type_set_printer 54 | end type mac_type 55 | 56 | type, extends(computer_type) :: windows_type 57 | class(printer_type), pointer :: printer 58 | contains 59 | procedure :: print => windows_type_print 60 | procedure :: set_printer => windows_type_set_printer 61 | end type windows_type 62 | 63 | contains 64 | 65 | subroutine windows_type_print(self) 66 | class(windows_type), intent(inout) :: self 67 | print *, "Print request for windows" 68 | call self%printer%print_file() 69 | end subroutine windows_type_print 70 | 71 | subroutine windows_type_set_printer(self, printer) 72 | class(windows_type), intent(inout) :: self 73 | class(printer_type), intent(inout), target :: printer 74 | self%printer => printer 75 | end subroutine windows_type_set_printer 76 | 77 | subroutine mac_type_print(self) 78 | class(mac_type), intent(inout) :: self 79 | print *, "Print request for mac" 80 | call self%printer%print_file() 81 | end subroutine mac_type_print 82 | 83 | subroutine mac_type_set_printer(self, printer) 84 | class(mac_type), intent(inout) :: self 85 | class(printer_type), intent(inout), target :: printer 86 | self%printer => printer 87 | end subroutine mac_type_set_printer 88 | 89 | subroutine epson_type_print_file(self) 90 | class(epson_type), intent(inout) :: self 91 | print *, "Printing by a EPSON Printer" 92 | end subroutine epson_type_print_file 93 | 94 | subroutine hp_type_print_file(self) 95 | class(hp_type), intent(inout) :: self 96 | print *, "Printing by a HP Printer" 97 | end subroutine hp_type_print_file 98 | 99 | end module bridge_module 100 | -------------------------------------------------------------------------------- /src/structural/cache/cache_main.f90: -------------------------------------------------------------------------------- 1 | program cache_main 2 | 3 | use cache_module, only: cache_factory_type, cache_type 4 | implicit none 5 | type(cache_factory_type) factory 6 | class(cache_type), pointer :: cache 7 | 8 | cache => factory%get_cache("A") 9 | call cache%operation() 10 | 11 | cache => factory%get_cache("A") 12 | call cache%operation() 13 | 14 | cache => factory%get_cache("B") 15 | call cache%operation() 16 | 17 | cache => factory%get_cache("C") 18 | call cache%operation() 19 | 20 | print *, "List length: ", size(factory%cache_list) 21 | 22 | end program cache_main 23 | 24 | !> Results shall be: 25 | 26 | ! A 27 | ! A 28 | ! B 29 | ! C 30 | ! List length: 3 31 | -------------------------------------------------------------------------------- /src/structural/cache/cache_module.f90: -------------------------------------------------------------------------------- 1 | module cache_module 2 | 3 | implicit none 4 | private 5 | 6 | public :: cache_type, cache_factory_type 7 | 8 | type, abstract :: cache_type 9 | contains 10 | procedure(cache_type_operation), deferred :: operation 11 | end type cache_type 12 | 13 | abstract interface 14 | subroutine cache_type_operation(self) 15 | import cache_type 16 | class(cache_type), intent(inout) :: self 17 | end subroutine cache_type_operation 18 | end interface 19 | 20 | type, extends(cache_type) :: concrete_cache_type 21 | character(:), allocatable :: key 22 | contains 23 | procedure :: operation => concrete_cache_type_operation 24 | end type concrete_cache_type 25 | 26 | type node_type 27 | class(cache_type), allocatable :: cache 28 | end type node_type 29 | 30 | type cache_factory_type 31 | type(node_type), allocatable :: cache_list(:) 32 | contains 33 | procedure :: get_cache => cache_factory_type_get_cache 34 | end type cache_factory_type 35 | 36 | contains 37 | 38 | subroutine concrete_cache_type_operation(self) 39 | class(concrete_cache_type), intent(inout) :: self 40 | print *, self%key 41 | end subroutine concrete_cache_type_operation 42 | 43 | function cache_factory_type_get_cache(self, key) result(cache) 44 | class(cache_factory_type), intent(inout), target :: self 45 | character(*), intent(in) :: key 46 | class(cache_type), pointer :: cache 47 | integer :: i 48 | 49 | if (allocated(self%cache_list)) then 50 | do i = 1, size(self%cache_list) 51 | associate (cache_ => self%cache_list(i)%cache) 52 | 53 | select type (cache_) 54 | type is (concrete_cache_type) 55 | if (cache_%key == key) then 56 | cache => self%cache_list(i)%cache 57 | return 58 | end if 59 | end select 60 | 61 | end associate 62 | end do 63 | end if 64 | 65 | self%cache_list = append_slice(self%cache_list, key) 66 | cache => self%cache_list(size(self%cache_list))%cache 67 | 68 | end function cache_factory_type_get_cache 69 | 70 | !> Date structure 71 | function append_slice(cache_list_in, key) result(cache_list_out) 72 | type(node_type), intent(inout), allocatable :: cache_list_in(:) 73 | character(*), intent(in) :: key 74 | type(node_type), allocatable :: cache_list_out(:) 75 | integer :: i 76 | 77 | if (.not. allocated(cache_list_in)) then 78 | allocate (cache_list_out(1)) 79 | allocate (cache_list_out(1)%cache, source=concrete_cache_type(key=key)) 80 | else 81 | i = size(cache_list_in) 82 | allocate (cache_list_out(i + 1)) 83 | cache_list_out(1:i) = cache_list_in 84 | allocate (cache_list_out(i + 1)%cache, source=concrete_cache_type(key=key)) 85 | end if 86 | end function append_slice 87 | 88 | end module cache_module 89 | -------------------------------------------------------------------------------- /src/structural/composite/composite_main.f90: -------------------------------------------------------------------------------- 1 | program composite_main 2 | use composite_module, only: file_type, folder_type 3 | implicit none 4 | type(file_type), target :: file1, file2, file3 5 | type(folder_type), target :: folder1 6 | type(folder_type) :: folder2 7 | 8 | file1%name = "File1" 9 | file2%name = "File2" 10 | file3%name = "File3" 11 | 12 | folder1%name = "Folder1" 13 | folder2%name = "Folder2" 14 | 15 | allocate (folder1%components(1)) 16 | folder1%components(1)%node => file1 17 | 18 | allocate (folder2%components(3)) 19 | folder2%components(1)%node => file2 20 | folder2%components(2)%node => file3 21 | folder2%components(3)%node => folder1 22 | 23 | call folder2%search("rose") 24 | 25 | end program composite_main 26 | 27 | !> Results shall be: 28 | 29 | ! Searching recursively for keyword rose in folder Folder2 30 | ! Searching for keyword rose in file File2 31 | ! Searching for keyword rose in file File3 32 | ! Searching recursively for keyword rose in folder Folder1 33 | ! Searching for keyword rose in file File1 -------------------------------------------------------------------------------- /src/structural/composite/composite_module.f90: -------------------------------------------------------------------------------- 1 | module composite_module 2 | 3 | implicit none 4 | private 5 | 6 | public :: file_type, folder_type 7 | 8 | type, abstract :: component_type 9 | contains 10 | procedure(component_type_search), deferred :: search 11 | end type component_type 12 | 13 | type, extends(component_type) :: file_type 14 | character(:), allocatable :: name 15 | contains 16 | procedure :: search => file_type_search 17 | procedure :: get_name => file_type_get_name 18 | end type file_type 19 | 20 | type node_t 21 | class(component_type), pointer :: node 22 | end type node_t 23 | 24 | type, extends(component_type) :: folder_type 25 | type(node_t), allocatable :: components(:) 26 | character(:), allocatable :: name 27 | contains 28 | procedure :: search => folder_type_search 29 | end type folder_type 30 | 31 | abstract interface 32 | subroutine component_type_search(self, keyward) 33 | import component_type 34 | class(component_type), intent(inout) :: self 35 | character(*), intent(in) :: keyward 36 | end subroutine component_type_search 37 | end interface 38 | 39 | contains 40 | 41 | subroutine file_type_search(self, keyward) 42 | class(file_type), intent(inout) :: self 43 | character(*), intent(in) :: keyward 44 | print *, "Searching for keyword ", keyward, " in file ", self%name 45 | end subroutine file_type_search 46 | 47 | function file_type_get_name(self) result(name) 48 | class(file_type), intent(inout) :: self 49 | character(:), allocatable :: name 50 | name = self%name 51 | end function file_type_get_name 52 | 53 | ! - - - - - - - - - - 54 | 55 | subroutine folder_type_search(self, keyward) 56 | class(folder_type), intent(inout) :: self 57 | character(*), intent(in) :: keyward 58 | integer :: i 59 | print *, "Searching recursively for keyword ", keyward, " in folder ", self%name 60 | if (size(self%components) == 0) return 61 | do i = 1, size(self%components) 62 | call self%components(i)%node%search(keyward) 63 | end do 64 | end subroutine folder_type_search 65 | 66 | end module composite_module 67 | -------------------------------------------------------------------------------- /src/structural/facade/facade_main.f90: -------------------------------------------------------------------------------- 1 | program facade_main 2 | use facade_module, only: wallet_facade_type, new_wallet_facade 3 | implicit none 4 | type(wallet_facade_type) :: wallet_facade 5 | 6 | wallet_facade = new_wallet_facade(account_id="abc", code=1234) 7 | call wallet_facade%add_money_to_wallet(account_id="abc", security_code=1234, amount=10) 8 | call wallet_facade%deduct_money_from_wallet(account_id="abc", security_code=1234, amount=5) 9 | 10 | end program facade_main 11 | 12 | !> Results shall be: 13 | 14 | ! Starting create account 15 | ! Account created 16 | ! Starting add money to wallet 17 | ! Account Verified 18 | ! SecurityCode Verified 19 | ! Wallet balance added successfully 20 | ! Sending wallet credit notification 21 | ! Make ledger entry for accountId abc with txnType credit for amount 10 22 | ! Starting debit money from wallet 23 | ! Account Verified 24 | ! SecurityCode Verified 25 | ! Wallet balance added successfully 26 | ! Sending wallet credit notification 27 | ! Make ledger entry for accountId abc with txnType credit for amount 5 -------------------------------------------------------------------------------- /src/structural/facade/facade_module.f90: -------------------------------------------------------------------------------- 1 | module facade_module 2 | 3 | implicit none 4 | private 5 | 6 | public :: new_wallet_facade, wallet_facade_type 7 | 8 | type account_type 9 | character(:), allocatable :: name 10 | contains 11 | procedure :: check_account => account_type_check_account 12 | end type account_type 13 | 14 | type security_code_type 15 | integer :: code 16 | contains 17 | procedure :: check_code => security_code_type_check_code 18 | end type security_code_type 19 | 20 | type wallet_type 21 | integer :: balance 22 | contains 23 | procedure :: credit_balance => wallet_type_credit_balance 24 | procedure :: debit_balance => wallet_type_debit_balance 25 | end type wallet_type 26 | 27 | type ledger_type 28 | contains 29 | procedure :: make_entry => ledger_type_make_entry 30 | end type ledger_type 31 | 32 | type notification_type 33 | contains 34 | procedure :: send_wallet_credit_notification => notification_type_send_wallet_credit_notification 35 | procedure :: send_wallet_debit_notification => notification_type_send_wallet_debit_notification 36 | end type notification_type 37 | 38 | type wallet_facade_type 39 | type(account_type) :: account 40 | type(wallet_type) :: wallet 41 | type(security_code_type) :: security_code 42 | type(notification_type) :: notification 43 | type(ledger_type) :: ledger 44 | contains 45 | procedure :: add_money_to_wallet => wallet_facade_type_add_money_to_wallet 46 | procedure :: deduct_money_from_wallet => wallet_facade_type_deduct_money_from_wallet 47 | end type wallet_facade_type 48 | 49 | contains 50 | 51 | function new_wallet_facade(account_id, code) result(wallet_facade) 52 | character(*), intent(in) :: account_id 53 | integer, intent(in) :: code 54 | type(wallet_facade_type) :: wallet_facade 55 | print *, "Starting create account" 56 | wallet_facade = wallet_facade_type(account=account_type(account_id), & 57 | security_code=security_code_type(code), & 58 | wallet=wallet_type(balance=0), & 59 | notification=notification_type(), & 60 | ledger=ledger_type()) 61 | print *, "Account created" 62 | end function new_wallet_facade 63 | 64 | subroutine wallet_facade_type_add_money_to_wallet(self, account_id, security_code, amount) 65 | class(wallet_facade_type), intent(inout) :: self 66 | character(*), intent(in) :: account_id 67 | integer, intent(in) :: security_code, amount 68 | print *, "Starting add money to wallet" 69 | call self%account%check_account(account_id) 70 | call self%security_code%check_code(security_code) 71 | call self%wallet%credit_balance(amount) 72 | call self%notification%send_wallet_credit_notification() 73 | call self%ledger%make_entry(account_id, "credit", amount) 74 | end subroutine wallet_facade_type_add_money_to_wallet 75 | 76 | subroutine wallet_facade_type_deduct_money_from_wallet(self, account_id, security_code, amount) 77 | class(wallet_facade_type), intent(inout) :: self 78 | character(*), intent(in) :: account_id 79 | integer, intent(in) :: security_code, amount 80 | print *, "Starting debit money from wallet" 81 | call self%account%check_account(account_id) 82 | call self%security_code%check_code(security_code) 83 | call self%wallet%credit_balance(amount) 84 | call self%notification%send_wallet_credit_notification() 85 | call self%ledger%make_entry(account_id, "credit", amount) 86 | end subroutine wallet_facade_type_deduct_money_from_wallet 87 | 88 | ! - - - - - - - - - 89 | 90 | subroutine account_type_check_account(self, account_name) 91 | class(account_type), intent(inout) :: self 92 | character(*), intent(in) :: account_name 93 | if (self%name /= account_name) then 94 | error stop "Account Name is incorrect" 95 | end if 96 | print *, "Account Verified" 97 | end subroutine account_type_check_account 98 | 99 | ! - - - - - - - - - 100 | 101 | subroutine security_code_type_check_code(self, incomming_code) 102 | class(security_code_type), intent(inout) :: self 103 | integer, intent(in) :: incomming_code 104 | if (self%code /= incomming_code) then 105 | error stop "Security Code is incorrect" 106 | end if 107 | print *, "SecurityCode Verified" 108 | end subroutine security_code_type_check_code 109 | 110 | ! - - - - - - - - - 111 | 112 | subroutine wallet_type_credit_balance(self, amount) 113 | class(wallet_type), intent(inout) :: self 114 | integer, intent(in) :: amount 115 | self%balance = self%balance + amount 116 | print *, "Wallet balance added successfully" 117 | end subroutine wallet_type_credit_balance 118 | 119 | subroutine wallet_type_debit_balance(self, amount) 120 | class(wallet_type), intent(inout) :: self 121 | integer, intent(in) :: amount 122 | if (self%balance < amount) then 123 | error stop "Balance is not sufficient" 124 | end if 125 | print *, "Wallet balance is Sufficient" 126 | self%balance = self%balance - amount 127 | end subroutine wallet_type_debit_balance 128 | 129 | ! - - - - - - - - - 130 | 131 | subroutine ledger_type_make_entry(self, account_id, txn_type, amount) 132 | class(ledger_type), intent(inout) :: self 133 | character(*), intent(in) :: account_id, txn_type 134 | integer, intent(in) :: amount 135 | print *, "Make ledger entry for accountId ", account_id, & 136 | " with txnType ", txn_type, & 137 | " for amount ", amount 138 | end subroutine ledger_type_make_entry 139 | 140 | ! - - - - - - - - - 141 | 142 | subroutine notification_type_send_wallet_credit_notification(self) 143 | class(notification_type), intent(inout) :: self 144 | print *, "Sending wallet credit notification" 145 | end subroutine notification_type_send_wallet_credit_notification 146 | 147 | subroutine notification_type_send_wallet_debit_notification(self) 148 | class(notification_type), intent(inout) :: self 149 | print *, "Sending wallet debit notification" 150 | end subroutine notification_type_send_wallet_debit_notification 151 | 152 | end module facade_module 153 | -------------------------------------------------------------------------------- /src/structural/proxy/proxy_main.f90: -------------------------------------------------------------------------------- 1 | program proxy_main 2 | 3 | use, intrinsic :: iso_fortran_env, only: int16 4 | use proxy_module, only: nginx_type, new_nginx_server 5 | 6 | type(nginx_type) :: nginx_server 7 | character(*), parameter :: app_status_url = "/app/status", create_user_url = "/create/user" 8 | integer(int16) :: code 9 | character(:), allocatable :: body 10 | 11 | nginx_server = new_nginx_server() 12 | 13 | call nginx_server%handle_request(app_status_url, "GET", code, body) 14 | print *, "Url: ", app_status_url, new_line(""), & 15 | "Http code: ", code, new_line(""), & 16 | "Body: ", body 17 | 18 | call nginx_server%handle_request(app_status_url, "GET", code, body) 19 | print *, "Url: ", app_status_url, new_line(""), & 20 | "Http code: ", code, new_line(""), & 21 | "Body: ", body 22 | 23 | call nginx_server%handle_request(app_status_url, "GET", code, body) 24 | print *, "Url: ", app_status_url, new_line(""), & 25 | "Http code: ", code, new_line(""), & 26 | "Body: ", body 27 | 28 | call nginx_server%handle_request(create_user_url, "POST", code, body) 29 | print *, "Url: ", create_user_url, new_line(""), & 30 | "Http code: ", code, new_line(""), & 31 | "Body: ", body 32 | 33 | call nginx_server%handle_request(create_user_url, "GET", code, body) 34 | print *, "Url: ", create_user_url, new_line(""), & 35 | "Http code: ", code, new_line(""), & 36 | "Body: ", body 37 | 38 | end program proxy_main 39 | 40 | !> Results shall be: 41 | 42 | ! Url: /app/status 43 | ! Http code: 200 44 | ! Body: Ok 45 | ! Url: /app/status 46 | ! Http code: 200 47 | ! Body: Ok 48 | ! Url: /app/status 49 | ! Http code: 403 50 | ! Body: Not Allowed 51 | ! Url: /create/user 52 | ! Http code: 201 53 | ! Body: User Created 54 | ! Url: /create/user 55 | ! Http code: 404 56 | ! Body: Not Ok -------------------------------------------------------------------------------- /src/structural/proxy/proxy_module.f90: -------------------------------------------------------------------------------- 1 | module proxy_module 2 | 3 | use, intrinsic :: iso_fortran_env, only: int16 4 | implicit none 5 | private 6 | 7 | public :: nginx_type, new_nginx_server 8 | 9 | type, abstract :: server_type 10 | contains 11 | procedure(server_type_handle_request), deferred :: handle_request 12 | end type server_type 13 | 14 | abstract interface 15 | subroutine server_type_handle_request(self, url, method, code, msg) 16 | import server_type, int16 17 | class(server_type), intent(inout) :: self 18 | character(*), intent(in) :: url, method 19 | integer(int16), intent(out) :: code 20 | character(:), intent(out), allocatable :: msg 21 | end subroutine server_type_handle_request 22 | end interface 23 | 24 | type map_type 25 | character(:), allocatable :: url 26 | integer(int16) :: rate_limiter 27 | end type map_type 28 | 29 | type, extends(server_type) :: nginx_type 30 | type(application_type), allocatable :: application 31 | integer(int16) :: max_allowed_request 32 | type(map_type), allocatable :: map(:) 33 | ! TODO: 34 | contains 35 | procedure :: handle_request => nginx_t_handle_request 36 | procedure :: check_rate_limiting => nginx_t_check_rate_limiting 37 | end type nginx_type 38 | 39 | type, extends(server_type) :: application_type 40 | contains 41 | procedure :: handle_request => application_t_handle_request 42 | end type application_type 43 | 44 | contains 45 | 46 | type(nginx_type) function new_nginx_server() result(nginx) 47 | type(map_type), allocatable :: map_(:) 48 | ! TODO: 49 | allocate (map_(2)) 50 | map_(1) = map_type(url="/app/status", rate_limiter=0_int16) 51 | map_(2) = map_type(url="/create/user", rate_limiter=0_int16) 52 | 53 | nginx = nginx_type(application=application_type(), max_allowed_request=2, map=map_) ! TODO: 54 | end function new_nginx_server 55 | 56 | subroutine nginx_t_handle_request(self, url, method, code, msg) 57 | class(nginx_type), intent(inout) :: self 58 | character(*), intent(in) :: url, method 59 | integer(int16), intent(out) :: code 60 | character(:), intent(out), allocatable :: msg 61 | 62 | logical :: allowed 63 | 64 | allowed = self%check_rate_limiting(url) 65 | 66 | if (.not. allowed) then 67 | code = 403_int16 68 | msg = "Not Allowed" 69 | return 70 | end if 71 | 72 | call self%application%handle_request(url, method, code, msg) 73 | 74 | end subroutine nginx_t_handle_request 75 | 76 | logical function nginx_t_check_rate_limiting(self, url) result(allowed) 77 | class(nginx_type), intent(inout) :: self 78 | character(*), intent(in) :: url 79 | 80 | integer(int16) :: i 81 | 82 | do i = 1_int16, size(self%map, kind=int16) 83 | if (self%map(i)%url == url) exit 84 | end do 85 | 86 | ! i = i - 1_int16 87 | 88 | if (self%map(i)%rate_limiter == 0_int16) then 89 | self%map(i)%rate_limiter = 1_int16 90 | end if 91 | 92 | if (self%map(i)%rate_limiter > self%max_allowed_request) then 93 | allowed = .false. 94 | return 95 | end if 96 | 97 | allowed = .true. 98 | self%map(i)%rate_limiter = self%map(i)%rate_limiter + 1_int16 99 | 100 | end function nginx_t_check_rate_limiting 101 | 102 | subroutine application_t_handle_request(self, url, method, code, msg) 103 | class(application_type), intent(inout) :: self 104 | character(*), intent(in) :: url, method 105 | integer(int16), intent(out) :: code 106 | character(:), intent(out), allocatable :: msg 107 | 108 | if (url == "/app/status" .and. method == "GET") then 109 | code = 200_int16 110 | msg = "Ok" 111 | return 112 | end if 113 | 114 | if (url == "/create/user" .and. method == "POST") then 115 | code = 201_int16 116 | msg = "User Created" 117 | return 118 | end if 119 | 120 | code = 404_int16 121 | msg = "Not Ok" 122 | 123 | end subroutine application_t_handle_request 124 | 125 | end module proxy_module 126 | -------------------------------------------------------------------------------- /src/structural/wrapper/wrapper_main.f90: -------------------------------------------------------------------------------- 1 | program wrapper_main 2 | 3 | use wrapper_module, only: vegge_mania_type, cheese_topping_type, tomato_topping_type 4 | implicit none 5 | type(vegge_mania_type), target :: pizza 6 | type(cheese_topping_type), target :: pizza_with_cheese 7 | type(tomato_topping_type) :: pizza_with_tomato_and_cheese 8 | 9 | pizza_with_cheese%pizza => pizza 10 | pizza_with_tomato_and_cheese%pizza => pizza_with_cheese 11 | 12 | print *, "Prince of veggeMania with tomato and cheese topping is ", pizza_with_tomato_and_cheese%get_price() 13 | 14 | end program wrapper_main 15 | 16 | !> Results shall be: 17 | 18 | ! Prince of veggeMania with tomato and cheese topping is 32. 19 | -------------------------------------------------------------------------------- /src/structural/wrapper/wrapper_module.f90: -------------------------------------------------------------------------------- 1 | module wrapper_module 2 | 3 | implicit none 4 | private 5 | 6 | public :: vegge_mania_type, tomato_topping_type, cheese_topping_type 7 | 8 | type, abstract :: pizza_type 9 | contains 10 | procedure(pizza_t_get_price), deferred :: get_price 11 | end type pizza_type 12 | 13 | abstract interface 14 | function pizza_t_get_price(self) result(price) 15 | import :: pizza_type 16 | class(pizza_type), intent(inout) :: self 17 | integer :: price 18 | end function pizza_t_get_price 19 | end interface 20 | 21 | type, extends(pizza_type) :: vegge_mania_type 22 | contains 23 | procedure :: get_price => vegge_mania_type_get_price 24 | end type vegge_mania_type 25 | 26 | type, extends(pizza_type) :: tomato_topping_type 27 | class(pizza_type), pointer :: pizza 28 | contains 29 | procedure :: get_price => tomato_topping_type_get_price 30 | end type tomato_topping_type 31 | 32 | type, extends(pizza_type) :: cheese_topping_type 33 | class(pizza_type), pointer :: pizza 34 | contains 35 | procedure :: get_price => cheese_topping_type_get_price 36 | end type cheese_topping_type 37 | 38 | contains 39 | 40 | function vegge_mania_type_get_price(self) result(price) 41 | class(vegge_mania_type), intent(inout) :: self 42 | integer :: price 43 | price = 15 44 | end function vegge_mania_type_get_price 45 | 46 | function tomato_topping_type_get_price(self) result(price) 47 | class(tomato_topping_type), intent(inout) :: self 48 | integer :: price 49 | price = self%pizza%get_price() + 7 50 | end function tomato_topping_type_get_price 51 | 52 | function cheese_topping_type_get_price(self) result(price) 53 | class(cheese_topping_type), intent(inout) :: self 54 | integer :: price 55 | price = self%pizza%get_price() + 10 56 | end function cheese_topping_type_get_price 57 | 58 | end module wrapper_module 59 | --------------------------------------------------------------------------------