Import
This commit is contained in:
commit
9b98af91a8
|
|
@ -0,0 +1,2 @@
|
|||
*.exe
|
||||
*.o
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
program entreprise_hello
|
||||
implicit none
|
||||
|
||||
character(len=*), parameter :: PERSON = "World"
|
||||
character(len=:), allocatable :: greeting
|
||||
|
||||
greeting = greet(PERSON)
|
||||
print '(A)', greeting
|
||||
contains
|
||||
pure function greet(person_) result(greeting_)
|
||||
character(len=*), intent(in) :: person_
|
||||
character(len=:), allocatable :: greeting_
|
||||
|
||||
greeting_ = "Hello, " // person_ // "!"
|
||||
end function greet
|
||||
end program entreprise_hello
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
program hello
|
||||
print *, "Hello, world !"
|
||||
end program hello
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
program Fibonacci
|
||||
implicit none
|
||||
|
||||
integer :: i
|
||||
integer, dimension(10) :: fib_nb
|
||||
|
||||
fib_nb(1) = 1
|
||||
fib_nb(2) = 1
|
||||
|
||||
do i = 3, 10
|
||||
fib_nb(i) = fib_nb(i-1) + fib_nb(i-2)
|
||||
end do
|
||||
|
||||
do i = 1, 10
|
||||
print *, fib_nb(i)
|
||||
end do
|
||||
contains
|
||||
recursive function fib(n) result(fib_)
|
||||
integer, intent(in) :: n
|
||||
integer :: fib_
|
||||
|
||||
if (n == 1) then
|
||||
fib_ = 1
|
||||
else if (n == 1) then
|
||||
fib_ = 1
|
||||
else
|
||||
fib_ = fib(n-1) + fib(n-2)
|
||||
end if
|
||||
end function fib
|
||||
end program Fibonacci
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
program uninitialized_example
|
||||
implicit none
|
||||
|
||||
character(len=10) :: something
|
||||
|
||||
print *, something
|
||||
end program uninitialized_example
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
program variables_example
|
||||
implicit none
|
||||
|
||||
integer :: x
|
||||
integer :: y
|
||||
integer :: z
|
||||
integer, parameter :: inches_per_foot = 12
|
||||
|
||||
print *, "x = ", x, "y = ", y, "z = ", z
|
||||
print *, "inches_per_foot = ", inches_per_foot
|
||||
|
||||
x = 3
|
||||
|
||||
print *, "x = ", x, "y = ", y, "z = ", z
|
||||
|
||||
y = 4
|
||||
|
||||
print *, "x = ", x, "y = ", y, "z = ", z
|
||||
|
||||
z = x + y
|
||||
|
||||
print *, "x = ", x, "y = ", y, "z = ", z
|
||||
|
||||
x = 1
|
||||
|
||||
print *, "x = ", x, "y = ", y, "z = ", z
|
||||
|
||||
end program variables_example
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
# From https://github.com/llamm-de/VSCode_Fortran_Tutorial
|
||||
# variables
|
||||
RM = del /Q /F
|
||||
|
||||
FC=gfortran
|
||||
CFLAGS=-c -g -Og -Wall
|
||||
FILE=take_notes
|
||||
|
||||
# linking
|
||||
a.exe: $(FILE).o
|
||||
$(FC) $(FILE).o
|
||||
|
||||
# compiling
|
||||
$(FILE).o: $(FILE).f90
|
||||
$(FC) $(CFLAGS) $(FILE).f90
|
||||
|
||||
|
||||
# cleanup
|
||||
clean:
|
||||
-$(RM) $(FILE).o a.exe
|
||||
|
||||
# run
|
||||
run:
|
||||
make
|
||||
./a.exe
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
program take_notes
|
||||
implicit none
|
||||
|
||||
character(len=*), parameter :: NOTES_FILE = "notes.txt"
|
||||
character(len=100) :: note
|
||||
integer :: unit
|
||||
|
||||
open(newunit = unit, file = NOTES_FILE, position = 'APPEND')
|
||||
|
||||
do
|
||||
print *, "Enter some notes. Enter 'DONE' to quit."
|
||||
read(*, '(A)') note
|
||||
if (trim(note) == "DONE") exit
|
||||
write(unit, '(A)') trim(note)
|
||||
end do
|
||||
|
||||
close(unit)
|
||||
end program take_notes
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
program to_the_power
|
||||
implicit none
|
||||
|
||||
integer :: base
|
||||
integer :: power
|
||||
integer :: status
|
||||
|
||||
do
|
||||
print *, "What’s the base number?"
|
||||
read(*, *, iostat=status) base
|
||||
if (status == 0) exit
|
||||
print *, "Sorry, I didn’t understand that."
|
||||
end do
|
||||
|
||||
do
|
||||
print *, "To what power?"
|
||||
read(*, *, iostat=status) power
|
||||
if (status == 0) exit
|
||||
print *, "Sorry, I didn’t understand that."
|
||||
end do
|
||||
|
||||
print *, base, "**", power, " is ", base**power
|
||||
end program to_the_power
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
program todo
|
||||
use todo_m, only: Todo_t
|
||||
|
||||
implicit none
|
||||
|
||||
type(Todo_t) :: todo_list
|
||||
|
||||
call todo_list%readPreviousTasks()
|
||||
call todo_list%interact()
|
||||
end program todo
|
||||
|
|
@ -0,0 +1,124 @@
|
|||
module todo_m
|
||||
implicit none
|
||||
private
|
||||
|
||||
integer, parameter :: MAX_TASKS = 99
|
||||
integer, parameter :: TASK_LENGTH = 100
|
||||
character(len=*), parameter :: TODO_FILE = "todo.txt"
|
||||
|
||||
type, public :: Todo_t
|
||||
private
|
||||
character(len=TASK_LENGTH) :: tasks(MAX_TASKS)
|
||||
integer :: num_tasks
|
||||
contains
|
||||
private
|
||||
procedure, public :: readPreviousTasks
|
||||
procedure, public :: interact
|
||||
procedure :: add
|
||||
procedure :: delete
|
||||
procedure :: save
|
||||
end type Todo_t
|
||||
contains
|
||||
subroutine readPreviousTasks(self)
|
||||
class(Todo_t), intent(out) :: self
|
||||
|
||||
integer :: i
|
||||
integer :: status
|
||||
integer :: unit
|
||||
|
||||
open(newunit=unit, file=TODO_FILE)
|
||||
|
||||
do i = 1, MAX_TASKS
|
||||
read(unit, '(A)', iostat=status) self%tasks(i)
|
||||
if (status /= 0) then
|
||||
self%num_tasks = i - 1
|
||||
exit
|
||||
else
|
||||
self%num_tasks = i
|
||||
end if
|
||||
end do
|
||||
|
||||
close(unit)
|
||||
end subroutine readPreviousTasks
|
||||
|
||||
subroutine interact(self)
|
||||
class(Todo_t), intent(inout) :: self
|
||||
|
||||
integer :: i
|
||||
character(len=1) :: response
|
||||
|
||||
do
|
||||
print *, "Here are your current tasks"
|
||||
do i = 1, self%num_tasks
|
||||
print '(I3,") ",A)', i, trim(self%tasks(i))
|
||||
end do
|
||||
|
||||
print *, "What would you like to do? (a)dd, (d)elete, (q)uit"
|
||||
read(*, '(A1)') response
|
||||
|
||||
select case (response)
|
||||
case ('a')
|
||||
call self%add()
|
||||
case ('d')
|
||||
call self%delete()
|
||||
case ('q')
|
||||
exit
|
||||
case default
|
||||
print *, "Sorry, I didn't understand that."
|
||||
end select
|
||||
|
||||
call self%save()
|
||||
end do
|
||||
end subroutine interact
|
||||
|
||||
subroutine add(self)
|
||||
class(Todo_t), intent(inout) :: self
|
||||
|
||||
print *, "What's the task?"
|
||||
self%num_tasks = self%num_tasks + 1
|
||||
read(*, '(A)') self%tasks(self%num_tasks)
|
||||
end subroutine add
|
||||
|
||||
subroutine delete(self)
|
||||
class(Todo_t), intent(inout) :: self
|
||||
|
||||
integer :: i
|
||||
integer :: status
|
||||
integer :: task
|
||||
|
||||
do
|
||||
print *, "Which one would you like to delete?"
|
||||
read(*, *, iostat=status) task
|
||||
if (status == 0) then
|
||||
if (task < 1) then
|
||||
print *, "Task number must be > 1"
|
||||
else if (task > self%num_tasks) then
|
||||
print *, "Task number must be <= ", self%num_tasks
|
||||
else
|
||||
do i = task, self%num_tasks
|
||||
self%tasks(i) = self%tasks(i+1)
|
||||
end do
|
||||
self%num_tasks = self%num_tasks - 1
|
||||
exit
|
||||
end if
|
||||
else
|
||||
print *, "Sorry, I didn't understand that."
|
||||
end if
|
||||
end do
|
||||
end subroutine delete
|
||||
|
||||
subroutine save(self)
|
||||
class(Todo_t), intent(in) :: self
|
||||
|
||||
integer :: i
|
||||
integer :: unit
|
||||
|
||||
open(newunit=unit, file=TODO_FILE, status='REPLACE')
|
||||
|
||||
do i = 1, self%num_tasks
|
||||
write(unit, '(A)') trim(self%tasks(i))
|
||||
end do
|
||||
|
||||
close(unit)
|
||||
end subroutine save
|
||||
end module todo_m
|
||||
Binary file not shown.
|
|
@ -0,0 +1,116 @@
|
|||
module todo_routines_m
|
||||
implicit none
|
||||
|
||||
integer, parameter :: MAX_TASKS = 99
|
||||
integer, parameter :: TASK_LENGTH = 100
|
||||
character(len=*), parameter :: TODO_FILE = "todo.txt"
|
||||
|
||||
contains
|
||||
subroutine readPreviousTasks(tasks_, num_tasks_)
|
||||
character(len=TASK_LENGTH), intent(out) :: tasks_(MAX_TASKS)
|
||||
integer, intent(out) :: num_tasks_
|
||||
|
||||
integer :: i
|
||||
integer :: status
|
||||
integer :: unit
|
||||
|
||||
open(newunit=unit, file=TODO_FILE)
|
||||
|
||||
do i = 1, MAX_TASKS
|
||||
read(unit, '(A)', iostat=status) tasks_(i)
|
||||
if (status /= 0) then
|
||||
num_tasks_ = i - 1
|
||||
exit
|
||||
else
|
||||
num_tasks_ = i
|
||||
end if
|
||||
end do
|
||||
|
||||
close(unit)
|
||||
end subroutine readPreviousTasks
|
||||
|
||||
subroutine interact(tasks_, num_tasks_)
|
||||
character(len=TASK_LENGTH), intent(inout) :: tasks_(MAX_TASKS)
|
||||
integer, intent(inout) :: num_tasks_
|
||||
|
||||
integer :: i
|
||||
character(len=1) :: response
|
||||
|
||||
do
|
||||
print *, "Here are your current tasks"
|
||||
do i = 1, num_tasks_
|
||||
print '(I3,") ",A)', i, trim(tasks_(i))
|
||||
end do
|
||||
|
||||
print *, "What would you like to do? (a)dd, (d)elete, (q)uit"
|
||||
read(*, '(A1)') response
|
||||
|
||||
select case (response)
|
||||
case ('a')
|
||||
call add(tasks_, num_tasks_)
|
||||
case ('d')
|
||||
call delete(tasks_, num_tasks_)
|
||||
case ('q')
|
||||
exit
|
||||
case default
|
||||
print *, "Sorry, I didn't understand that."
|
||||
end select
|
||||
|
||||
call save(tasks_, num_tasks_)
|
||||
end do
|
||||
end subroutine interact
|
||||
|
||||
subroutine add(tasks_, num_tasks_)
|
||||
character(len=TASK_LENGTH), intent(inout) :: tasks_(MAX_TASKS)
|
||||
integer, intent(inout) :: num_tasks_
|
||||
|
||||
print *, "What's the task?"
|
||||
num_tasks_ = num_tasks_ + 1
|
||||
read(*, '(A)') tasks_(num_tasks_)
|
||||
end subroutine add
|
||||
|
||||
subroutine delete(tasks_, num_tasks_)
|
||||
character(len=TASK_LENGTH), intent(inout) :: tasks_(MAX_TASKS)
|
||||
integer, intent(inout) :: num_tasks_
|
||||
|
||||
integer :: i
|
||||
integer :: status
|
||||
integer :: task
|
||||
|
||||
do
|
||||
print *, "Which one would you like to delete?"
|
||||
read(*, *, iostat=status) task
|
||||
if (status == 0) then
|
||||
if (task < 1) then
|
||||
print *, "Task number must be > 1"
|
||||
else if (task > num_tasks_) then
|
||||
print *, "Task number must be <= ", num_tasks_
|
||||
else
|
||||
do i = task, num_tasks_
|
||||
tasks_(i) = tasks_(i+1)
|
||||
end do
|
||||
num_tasks_ = num_tasks_ - 1
|
||||
exit
|
||||
end if
|
||||
else
|
||||
print *, "Sorry, I didn't understand that."
|
||||
end if
|
||||
end do
|
||||
end subroutine delete
|
||||
|
||||
subroutine save(tasks_, num_tasks_)
|
||||
character(len=TASK_LENGTH), intent(in) :: tasks_(MAX_TASKS)
|
||||
integer, intent(in) :: num_tasks_
|
||||
|
||||
integer :: i
|
||||
integer :: unit
|
||||
|
||||
open(newunit=unit, file=TODO_FILE, status='REPLACE')
|
||||
|
||||
do i = 1, num_tasks_
|
||||
write(unit, '(A)') trim(tasks_(i))
|
||||
end do
|
||||
|
||||
close(unit)
|
||||
end subroutine save
|
||||
end module todo_routines_m
|
||||
Binary file not shown.
|
|
@ -0,0 +1,17 @@
|
|||
RM = del /Q /F
|
||||
|
||||
todo: todo_m.o todo.o
|
||||
gfortran todo_m.o todo.o -o todo
|
||||
|
||||
todo.o: todo.f90 todo_m.mod
|
||||
gfortran -c todo.f90 -o todo.o
|
||||
|
||||
todo_m.o todo_m.mod: todo_m.f90
|
||||
gfortran -c todo_m.f90 -o todo_m.o
|
||||
|
||||
# .PHONY: clean
|
||||
clean:
|
||||
-$(RM) todo todo.o todo_m.o todo_m.mod
|
||||
clean_exe:
|
||||
make clean
|
||||
-$(RM) todo.exe
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
program todo
|
||||
use todo_m, only: Todo_t
|
||||
|
||||
implicit none
|
||||
|
||||
type(Todo_t) :: todo_list
|
||||
|
||||
call todo_list%readPreviousTasks()
|
||||
call todo_list%interact()
|
||||
end program todo
|
||||
|
|
@ -0,0 +1,124 @@
|
|||
module todo_m
|
||||
implicit none
|
||||
private
|
||||
|
||||
integer, parameter :: MAX_TASKS = 99
|
||||
integer, parameter :: TASK_LENGTH = 100
|
||||
character(len=*), parameter :: TODO_FILE = "todo.txt"
|
||||
|
||||
type, public :: Todo_t
|
||||
private
|
||||
character(len=TASK_LENGTH) :: tasks(MAX_TASKS)
|
||||
integer :: num_tasks
|
||||
contains
|
||||
private
|
||||
procedure, public :: readPreviousTasks
|
||||
procedure, public :: interact
|
||||
procedure :: add
|
||||
procedure :: delete
|
||||
procedure :: save
|
||||
end type Todo_t
|
||||
contains
|
||||
subroutine readPreviousTasks(self)
|
||||
class(Todo_t), intent(out) :: self
|
||||
|
||||
integer :: i
|
||||
integer :: status
|
||||
integer :: unit
|
||||
|
||||
open(newunit=unit, file=TODO_FILE)
|
||||
|
||||
do i = 1, MAX_TASKS
|
||||
read(unit, '(A)', iostat=status) self%tasks(i)
|
||||
if (status /= 0) then
|
||||
self%num_tasks = i - 1
|
||||
exit
|
||||
else
|
||||
self%num_tasks = i
|
||||
end if
|
||||
end do
|
||||
|
||||
close(unit)
|
||||
end subroutine readPreviousTasks
|
||||
|
||||
subroutine interact(self)
|
||||
class(Todo_t), intent(inout) :: self
|
||||
|
||||
integer :: i
|
||||
character(len=1) :: response
|
||||
|
||||
do
|
||||
print *, "Here are your current tasks"
|
||||
do i = 1, self%num_tasks
|
||||
print '(I3,") ",A)', i, trim(self%tasks(i))
|
||||
end do
|
||||
|
||||
print *, "What would you like to do? (a)dd, (d)elete, (q)uit"
|
||||
read(*, '(A1)') response
|
||||
|
||||
select case (response)
|
||||
case ('a')
|
||||
call self%add()
|
||||
case ('d')
|
||||
call self%delete()
|
||||
case ('q')
|
||||
exit
|
||||
case default
|
||||
print *, "Sorry, I didn't understand that."
|
||||
end select
|
||||
|
||||
call self%save()
|
||||
end do
|
||||
end subroutine interact
|
||||
|
||||
subroutine add(self)
|
||||
class(Todo_t), intent(inout) :: self
|
||||
|
||||
print *, "What's the task?"
|
||||
self%num_tasks = self%num_tasks + 1
|
||||
read(*, '(A)') self%tasks(self%num_tasks)
|
||||
end subroutine add
|
||||
|
||||
subroutine delete(self)
|
||||
class(Todo_t), intent(inout) :: self
|
||||
|
||||
integer :: i
|
||||
integer :: status
|
||||
integer :: task
|
||||
|
||||
do
|
||||
print *, "Which one would you like to delete?"
|
||||
read(*, *, iostat=status) task
|
||||
if (status == 0) then
|
||||
if (task < 1) then
|
||||
print *, "Task number must be > 1"
|
||||
else if (task > self%num_tasks) then
|
||||
print *, "Task number must be <= ", self%num_tasks
|
||||
else
|
||||
do i = task, self%num_tasks
|
||||
self%tasks(i) = self%tasks(i+1)
|
||||
end do
|
||||
self%num_tasks = self%num_tasks - 1
|
||||
exit
|
||||
end if
|
||||
else
|
||||
print *, "Sorry, I didn't understand that."
|
||||
end if
|
||||
end do
|
||||
end subroutine delete
|
||||
|
||||
subroutine save(self)
|
||||
class(Todo_t), intent(in) :: self
|
||||
|
||||
integer :: i
|
||||
integer :: unit
|
||||
|
||||
open(newunit=unit, file=TODO_FILE, status='REPLACE')
|
||||
|
||||
do i = 1, self%num_tasks
|
||||
write(unit, '(A)') trim(self%tasks(i))
|
||||
end do
|
||||
|
||||
close(unit)
|
||||
end subroutine save
|
||||
end module todo_m
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
*.exe
|
||||
*.mod
|
||||
*.o
|
||||
|
|
@ -0,0 +1,57 @@
|
|||
module reduce_m
|
||||
implicit none
|
||||
|
||||
type, abstract :: accumulator_t
|
||||
contains
|
||||
procedure(combiner), deferred, nopass :: combine
|
||||
end type
|
||||
|
||||
abstract interface
|
||||
pure function combiner(x, y) result(z)
|
||||
integer, intent(in) :: x
|
||||
integer, intent(in) :: y
|
||||
integer :: z
|
||||
end function
|
||||
end interface
|
||||
contains
|
||||
pure recursive function reduce(vals, accumulator, init) result(combined)
|
||||
integer, intent(in) :: vals(:)
|
||||
class(accumulator_t), intent(in) :: accumulator
|
||||
integer, intent(in) :: init
|
||||
integer :: combined
|
||||
|
||||
if (size(vals) == 1) then
|
||||
combined = accumulator%combine(init, vals(1))
|
||||
else
|
||||
combined = reduce(vals(2:), accumulator, accumulator%combine(init, vals(1)))
|
||||
end if
|
||||
end function
|
||||
end module
|
||||
|
||||
module multiplier_m
|
||||
use reduce_m, only: accumulator_t
|
||||
|
||||
implicit none
|
||||
|
||||
type, extends(accumulator_t) :: multiplier_t
|
||||
contains
|
||||
procedure, nopass :: combine => multiply
|
||||
end type
|
||||
contains
|
||||
pure function multiply(x, y) result(z)
|
||||
integer, intent(in) :: x
|
||||
integer, intent(in) :: y
|
||||
integer :: z
|
||||
|
||||
z = x * y
|
||||
end function
|
||||
end module
|
||||
|
||||
program main
|
||||
use multiplier_m, only: multiplier_t
|
||||
use reduce_m, only: reduce
|
||||
|
||||
implicit none
|
||||
|
||||
print *, reduce([1, 2, 3, 4], multiplier_t(), 1)
|
||||
end program
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
program fibonaci_test
|
||||
implicit none
|
||||
|
||||
print *, fibonaci(6)
|
||||
contains
|
||||
recursive function fibonaci(number) result(fibonaci_number)
|
||||
integer, intent(in) :: number
|
||||
integer :: fibonaci_number
|
||||
|
||||
if (number <= 2) then
|
||||
fibonaci_number = 1
|
||||
else
|
||||
fibonaci_number = fibonaci(number - 1) + fibonaci(number - 2)
|
||||
end if
|
||||
print *, "result:", fibonaci_number
|
||||
end function
|
||||
end program
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
module reduce_m
|
||||
implicit none
|
||||
|
||||
abstract interface
|
||||
pure function combiner(x, y) result(z)
|
||||
integer, intent(in) :: x
|
||||
integer, intent(in) :: y
|
||||
integer :: z
|
||||
end function
|
||||
end interface
|
||||
contains
|
||||
pure recursive function reduce(vals, accumulator, init) result(combined)
|
||||
integer, intent(in) :: vals(:)
|
||||
procedure(combiner) :: accumulator
|
||||
integer, intent(in) :: init
|
||||
integer :: combined
|
||||
|
||||
if (size(vals) == 1) then
|
||||
combined = accumulator(init, vals(1))
|
||||
else
|
||||
combined = reduce(vals(2:), accumulator, accumulator(init, vals(1)))
|
||||
end if
|
||||
end function
|
||||
end module
|
||||
|
||||
module multiplier_m
|
||||
implicit none
|
||||
|
||||
contains
|
||||
pure function multiply(x, y) result(z)
|
||||
integer, intent(in) :: x
|
||||
integer, intent(in) :: y
|
||||
integer :: z
|
||||
|
||||
z = x * y
|
||||
end function
|
||||
end module
|
||||
|
||||
program main
|
||||
use multiplier_m, only: multiply
|
||||
use reduce_m, only: reduce
|
||||
|
||||
implicit none
|
||||
|
||||
print *, reduce([1, 2, 3, 4], multiply, 1)
|
||||
end program
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
program pure_and_elemental
|
||||
implicit none
|
||||
|
||||
integer, parameter :: numbers(*) = [2, 3, 5, 7, 11]
|
||||
|
||||
print *, multiply_by_three(numbers)
|
||||
contains
|
||||
elemental function multiply_by_three(number) result(multiplied_by_three)
|
||||
integer, intent(in) :: number
|
||||
integer :: multiplied_by_three
|
||||
|
||||
multiplied_by_three = number * 3
|
||||
end function
|
||||
end program
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
program pure_and_elemental_exercise
|
||||
implicit none
|
||||
|
||||
integer, parameter :: PRIMES(*) = [2, 3, 5, 7, 11]
|
||||
integer, parameter :: REAL_ANSWER = 1872
|
||||
integer :: answer
|
||||
|
||||
! Replace '42' with an expression using elemental functions
|
||||
! that calculates the equivalent of the following:
|
||||
! answer = 0
|
||||
! do i = 1, size(PRIMES)
|
||||
! answer = answer + (primes(i) * 3)**2
|
||||
! end do
|
||||
answer = sum(function_(primes))
|
||||
|
||||
if (answer == REAL_ANSWER) then
|
||||
print *, "You got it! :)"
|
||||
else
|
||||
print *, answer
|
||||
print *, "Not passing yet :("
|
||||
end if
|
||||
contains
|
||||
! put your functions down here
|
||||
elemental function function_(primes_) result(resu)
|
||||
integer, intent(in) :: primes_
|
||||
integer :: resu
|
||||
|
||||
resu = (primes_ * 3)**2
|
||||
end function
|
||||
end program
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
program pure_and_elemental_exercise
|
||||
implicit none
|
||||
|
||||
integer, parameter :: PRIMES(*) = [2, 3, 5, 7, 11]
|
||||
integer, parameter :: REAL_ANSWER = 1872
|
||||
integer :: answer
|
||||
|
||||
! Replace '42' with an expression using elemental functions
|
||||
! that calculates the equivalent of the following:
|
||||
! answer = 0
|
||||
! do i = 1, size(PRIMES)
|
||||
! answer = answer + (primes(i) * 3)**2
|
||||
! end do
|
||||
answer = sum(square(multiply_by_three(PRIMES)))
|
||||
! Note: intrinsic operators are already elemental, so the following works too
|
||||
! answer = sum((PRIMES * 3)**2)
|
||||
|
||||
if (answer == REAL_ANSWER) then
|
||||
print *, "You got it! :)"
|
||||
else
|
||||
print *, answer
|
||||
print *, "Not passing yet :("
|
||||
end if
|
||||
contains
|
||||
! put your functions down here
|
||||
elemental function multiply_by_three(number) result(multiplied_by_three)
|
||||
integer, intent(in) :: number
|
||||
integer :: multiplied_by_three
|
||||
|
||||
multiplied_by_three = number * 3
|
||||
end function
|
||||
|
||||
elemental function square(number) result(squared)
|
||||
integer, intent(in) :: number
|
||||
integer :: squared
|
||||
|
||||
squared = number ** 2
|
||||
end function
|
||||
end program
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
program recursive_sum_exercise
|
||||
implicit none
|
||||
|
||||
integer, parameter :: THE_NUMBERS(*) = [2, 3, 5, 7, 11]
|
||||
integer :: answer
|
||||
|
||||
answer = sum_(THE_NUMBERS)
|
||||
|
||||
if (answer == 28) then
|
||||
print *, "You got it! :)"
|
||||
else
|
||||
print *, answer
|
||||
print *, "Not quite right yet. :("
|
||||
end if
|
||||
contains
|
||||
recursive function sum_(numbers) result(total)
|
||||
integer, intent(in) :: numbers(:)
|
||||
integer :: total
|
||||
|
||||
total = 0
|
||||
if (size(numbers)==1) then
|
||||
total = numbers(1)
|
||||
else
|
||||
total = numbers(1) + sum_(numbers(2:))
|
||||
end if
|
||||
end function
|
||||
end program
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
program recursive_sum_exercise
|
||||
implicit none
|
||||
|
||||
integer, parameter :: THE_NUMBERS(*) = [2, 3, 5, 7, 11]
|
||||
integer :: answer
|
||||
|
||||
answer = sum2(THE_NUMBERS)
|
||||
|
||||
if (answer == 28) then
|
||||
print *, "You got it! :)"
|
||||
else
|
||||
print *, answer
|
||||
print *, "Not quite right yet. :("
|
||||
end if
|
||||
contains
|
||||
recursive function sum_(numbers) result(total)
|
||||
integer, intent(in) :: numbers(:)
|
||||
integer :: total
|
||||
|
||||
if (size(numbers) == 1) then
|
||||
total = numbers(1)
|
||||
else
|
||||
total = sum_(numbers(1:size(numbers)/2)) + sum_(numbers(size(numbers)/2+1:))
|
||||
end if
|
||||
end function
|
||||
|
||||
recursive function sum2(numbers) result(total)
|
||||
integer, intent(in) :: numbers(:)
|
||||
integer :: total
|
||||
|
||||
if (size(numbers) == 1) then
|
||||
total = numbers(1)
|
||||
else
|
||||
total = numbers(1) + sum2(numbers(2:))
|
||||
end if
|
||||
end function
|
||||
end program
|
||||
|
|
@ -0,0 +1,56 @@
|
|||
module reduce_m
|
||||
implicit none
|
||||
|
||||
abstract interface
|
||||
pure function combiner(x, y) result(z)
|
||||
integer, intent(in) :: x
|
||||
integer, intent(in) :: y
|
||||
integer :: z
|
||||
end function
|
||||
end interface
|
||||
contains
|
||||
pure recursive function reduce(vals, accumulator, init) result(combined)
|
||||
integer, intent(in) :: vals(:)
|
||||
procedure(combiner) :: accumulator
|
||||
integer, intent(in) :: init
|
||||
integer :: combined
|
||||
|
||||
if (size(vals) == 1) then
|
||||
combined = accumulator(init, vals(1))
|
||||
else
|
||||
combined = reduce(vals(2:), accumulator, accumulator(init, vals(1)))
|
||||
end if
|
||||
end function
|
||||
end module
|
||||
|
||||
program main
|
||||
use reduce_m, only: reduce
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: answer
|
||||
|
||||
answer = sum_([1, 2, 3, 4])
|
||||
|
||||
if (answer == 10) then
|
||||
print *, "You got it! :)"
|
||||
else
|
||||
print *, answer
|
||||
print *, "Not quite right yet. :("
|
||||
end if
|
||||
contains
|
||||
pure function sum_(numbers) result(total)
|
||||
integer, intent(in) :: numbers(:)
|
||||
integer :: total
|
||||
|
||||
total = reduce(numbers, add, 0)
|
||||
end function
|
||||
|
||||
pure function add(x, y) result(z)
|
||||
integer, intent(in) :: x
|
||||
integer, intent(in) :: y
|
||||
integer :: z
|
||||
|
||||
z = x + y
|
||||
end function
|
||||
end program
|
||||
|
|
@ -0,0 +1,56 @@
|
|||
module reduce_m
|
||||
implicit none
|
||||
|
||||
abstract interface
|
||||
pure function combiner(x, y) result(z)
|
||||
integer, intent(in) :: x
|
||||
integer, intent(in) :: y
|
||||
integer :: z
|
||||
end function
|
||||
end interface
|
||||
contains
|
||||
pure recursive function reduce(vals, accumulator, init) result(combined)
|
||||
integer, intent(in) :: vals(:)
|
||||
procedure(combiner) :: accumulator
|
||||
integer, intent(in) :: init
|
||||
integer :: combined
|
||||
|
||||
if (size(vals) == 1) then
|
||||
combined = accumulator(init, vals(1))
|
||||
else
|
||||
combined = reduce(vals(2:), accumulator, accumulator(init, vals(1)))
|
||||
end if
|
||||
end function
|
||||
end module
|
||||
|
||||
program main
|
||||
use reduce_m, only: reduce
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: answer
|
||||
|
||||
answer = sum_([1, 2, 3, 4])
|
||||
|
||||
if (answer == 10) then
|
||||
print *, "You got it! :)"
|
||||
else
|
||||
print *, answer
|
||||
print *, "Not quite right yet. :("
|
||||
end if
|
||||
contains
|
||||
pure function sum_(numbers) result(total)
|
||||
integer, intent(in) :: numbers(:)
|
||||
integer :: total
|
||||
|
||||
total = reduce(numbers, add, 0)
|
||||
end function
|
||||
|
||||
pure function add(x, y) result(z)
|
||||
integer, intent(in) :: x
|
||||
integer, intent(in) :: y
|
||||
integer :: z
|
||||
|
||||
z = x + y
|
||||
end function
|
||||
end program
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
program main
|
||||
use iso_varying_string, only: put_line
|
||||
use leaf_m, only: leaf_t
|
||||
use node_m, only: node_t
|
||||
use strff, only: to_string
|
||||
|
||||
implicit none
|
||||
|
||||
type(node_t) :: tree
|
||||
|
||||
tree = node_t( &
|
||||
node_t( &
|
||||
node_t( &
|
||||
node_t( &
|
||||
leaf_t(1), &
|
||||
leaf_t(23)), &
|
||||
leaf_t(4)), &
|
||||
leaf_t(567)), &
|
||||
node_t( &
|
||||
leaf_t(89), &
|
||||
node_t( &
|
||||
leaf_t(1234), &
|
||||
leaf_t(56))))
|
||||
|
||||
call put_line(tree%to_string())
|
||||
call put_line(to_string(tree%total()))
|
||||
end program
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
name = "binary_tree"
|
||||
version = "0.1.0"
|
||||
license = "MIT"
|
||||
author = "Brad Richardson"
|
||||
maintainer = "everythingfunctional@protonmail.com"
|
||||
copyright = "2021 Brad Richardson"
|
||||
|
||||
[dependencies]
|
||||
iso_varying_string = { git = "https://gitlab.com/everythingfunctional/iso_varying_string.git", tag = "v2.0.0" }
|
||||
strff = { git = "https://gitlab.com/everythingfunctional/strff.git", tag = "v2.0.1" }
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
module leaf_m
|
||||
use iso_varying_string, only: varying_string
|
||||
use strff, only: to_string
|
||||
use tree_m, only: tree_t
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: leaf_t
|
||||
|
||||
type, extends(tree_t) :: leaf_t
|
||||
private
|
||||
integer :: value_
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string => leaf_to_string
|
||||
procedure, public :: total
|
||||
end type
|
||||
|
||||
interface leaf_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(value_) result(leaf)
|
||||
integer, intent(in) :: value_
|
||||
type(leaf_t) :: leaf
|
||||
|
||||
leaf%value_ = value_
|
||||
end function
|
||||
|
||||
pure function leaf_to_string(self) result(string)
|
||||
class(leaf_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = to_string(self%value_)
|
||||
end function
|
||||
|
||||
pure function total(self)
|
||||
class(leaf_t), intent(in) :: self
|
||||
integer :: total
|
||||
|
||||
total = self%value_
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,162 @@
|
|||
module node_m
|
||||
use iso_varying_string, only: &
|
||||
varying_string, assignment(=), operator(//), len, trim, var_str
|
||||
use strff, only: join, split_at, NEWLINE
|
||||
use tree_m, only: tree_t
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: node_t
|
||||
|
||||
type, extends(tree_t) :: node_t
|
||||
private
|
||||
class(tree_t), allocatable :: left, right
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string
|
||||
procedure, public :: total
|
||||
end type
|
||||
|
||||
interface node_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
function constructor(left, right) result(node)
|
||||
class(tree_t), intent(in) :: left, right
|
||||
type(node_t) :: node
|
||||
|
||||
allocate(node%left, source = left)
|
||||
allocate(node%right, source = right)
|
||||
end function
|
||||
|
||||
pure recursive function to_string(self) result(string)
|
||||
class(node_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
type(varying_string) :: blocked
|
||||
type(varying_string), allocatable :: child_strings(:)
|
||||
type(varying_string) :: dashed_line
|
||||
integer :: height_
|
||||
type(varying_string), allocatable :: padded_strings(:)
|
||||
type(varying_string) :: pipes
|
||||
integer, allocatable :: widths(:)
|
||||
|
||||
allocate(child_strings, source = [self%left%to_string(), self%right%to_string()])
|
||||
allocate(widths, source = max_width(child_strings)+1)
|
||||
height_ = maxval(height(child_strings))
|
||||
dashed_line = make_dashes(widths)
|
||||
pipes = join(make_pipe(widths), "")
|
||||
allocate(padded_strings, source = pad_to(child_strings, widths, height_))
|
||||
blocked = join( &
|
||||
[ dashed_line&
|
||||
, pipes &
|
||||
, concat_lines(padded_strings) &
|
||||
], &
|
||||
NEWLINE)
|
||||
string = strip_trailing_space(blocked)
|
||||
end function
|
||||
|
||||
pure recursive function total(self)
|
||||
class(node_t), intent(in) :: self
|
||||
integer :: total
|
||||
|
||||
total = self%left%total() + self%right%total()
|
||||
end function
|
||||
|
||||
elemental function max_width(tree_string) result(width)
|
||||
type(varying_string), intent(in) :: tree_string
|
||||
integer :: width
|
||||
|
||||
width = maxval(len(split_at(tree_string, NEWLINE)))
|
||||
end function
|
||||
|
||||
elemental function height(tree_string)
|
||||
type(varying_string), intent(in) :: tree_string
|
||||
integer :: height
|
||||
|
||||
height = size(split_at(tree_string, NEWLINE))
|
||||
end function
|
||||
|
||||
elemental function pad_to(string, width, num_lines) result(padded)
|
||||
type(varying_string), intent(in) :: string
|
||||
integer, intent(in) :: width, num_lines
|
||||
type(varying_string) :: padded
|
||||
|
||||
integer :: i
|
||||
|
||||
associate(lines => split_at(string, NEWLINE))
|
||||
associate(padded_lines => pad_line(lines, width))
|
||||
padded = join([padded_lines, [(var_str(repeat(" ", width)), i = 1, num_lines - size(lines))]], NEWLINE)
|
||||
end associate
|
||||
end associate
|
||||
contains
|
||||
elemental function pad_line(line, width) result(padded_line)
|
||||
type(varying_string), intent(in) :: line
|
||||
integer, intent(in) :: width
|
||||
type(varying_string) :: padded_line
|
||||
|
||||
padded_line = line // repeat(" ", width - len(line))
|
||||
end function
|
||||
end function
|
||||
|
||||
pure function make_dashes(widths) result(dashes)
|
||||
integer, intent(in) :: widths(:)
|
||||
type(varying_string) :: dashes
|
||||
|
||||
if (size(widths) == 1) then
|
||||
dashes = make_pipe(widths(1))
|
||||
else
|
||||
associate( &
|
||||
leading_spaces => widths(1)/2 - 1, &
|
||||
trailing_spaces => widths(size(widths)) - widths(size(widths))/2, &
|
||||
total_width => sum(widths))
|
||||
associate(dash_width => total_width - leading_spaces - trailing_spaces)
|
||||
dashes = repeat(" ", leading_spaces) // repeat("-", dash_width) // repeat(" ", trailing_spaces)
|
||||
end associate
|
||||
end associate
|
||||
end if
|
||||
end function
|
||||
|
||||
elemental function make_pipe(width) result(pipe)
|
||||
integer, intent(in) :: width
|
||||
type(varying_string) :: pipe
|
||||
|
||||
pipe = center_in(var_str("|"), width)
|
||||
end function
|
||||
|
||||
pure function center_in(string, width) result(centered)
|
||||
type(varying_string), intent(in) :: string
|
||||
integer, intent(in) :: width
|
||||
type(varying_string) :: centered
|
||||
|
||||
associate(leading_spaces => width/2 - len(string)/2 - 1)
|
||||
associate(trailing_spaces => width - leading_spaces - len(string))
|
||||
centered = repeat(" ", leading_spaces) // string // repeat(" ", trailing_spaces)
|
||||
end associate
|
||||
end associate
|
||||
end function
|
||||
|
||||
pure function concat_lines(strings) result(joined)
|
||||
type(varying_string), intent(in) :: strings(:)
|
||||
type(varying_string) :: joined
|
||||
|
||||
integer :: i, j
|
||||
|
||||
associate(lines => [(split_at(strings(i), NEWLINE), i = 1, size(strings))])
|
||||
associate(num_lines => size(lines) / size(strings))
|
||||
joined = join( &
|
||||
[(join( &
|
||||
[(lines(i), i = j, num_lines*size(strings), num_lines)] &
|
||||
, ""), j = 1, num_lines)], &
|
||||
NEWLINE)
|
||||
end associate
|
||||
end associate
|
||||
end function
|
||||
|
||||
pure function strip_trailing_space(string) result(stripped)
|
||||
type(varying_string), intent(in) :: string
|
||||
type(varying_string) :: stripped
|
||||
|
||||
stripped = join(trim(split_at(string, NEWLINE)), NEWLINE)
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
module tree_m
|
||||
use iso_varying_string, only: varying_string
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: tree_t
|
||||
|
||||
type, abstract :: tree_t
|
||||
contains
|
||||
private
|
||||
procedure(to_string_i), public, deferred :: to_string
|
||||
procedure(total_i), public, deferred :: total
|
||||
end type
|
||||
|
||||
abstract interface
|
||||
pure function to_string_i(self) result(string)
|
||||
import :: tree_t, varying_string
|
||||
|
||||
implicit none
|
||||
|
||||
class(tree_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
end function
|
||||
|
||||
pure function total_i(self) result(total)
|
||||
import :: tree_t
|
||||
|
||||
implicit none
|
||||
|
||||
class(tree_t), intent(in) :: self
|
||||
integer :: total
|
||||
end function
|
||||
end interface
|
||||
end module
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
program main
|
||||
use iso_varying_string, only: put_line
|
||||
use leaf_m, only: leaf_t
|
||||
use node_m, only: node_t
|
||||
use tree_item_m, only: tree_item_t
|
||||
|
||||
implicit none
|
||||
|
||||
type(node_t) :: tree
|
||||
|
||||
tree = node_t( &
|
||||
[ tree_item_t(node_t( &
|
||||
[ tree_item_t(node_t( &
|
||||
[ tree_item_t(leaf_t(1)) &
|
||||
, tree_item_t(leaf_t(23)) &
|
||||
, tree_item_t(leaf_t(4)) &
|
||||
])) &
|
||||
, tree_item_t(leaf_t(567)) &
|
||||
])) &
|
||||
, tree_item_t(node_t( &
|
||||
[ tree_item_t(node_t( &
|
||||
[ tree_item_t(leaf_t(89)) &
|
||||
])) &
|
||||
, tree_item_t(node_t( &
|
||||
[ tree_item_t(leaf_t(1234)) &
|
||||
, tree_item_t(leaf_t(56)) &
|
||||
])) &
|
||||
])) &
|
||||
])
|
||||
|
||||
call put_line(tree%to_string())
|
||||
end program
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
name = "binary_tree"
|
||||
version = "0.1.0"
|
||||
license = "MIT"
|
||||
author = "Brad Richardson"
|
||||
maintainer = "everythingfunctional@protonmail.com"
|
||||
copyright = "2021 Brad Richardson"
|
||||
|
||||
[dependencies]
|
||||
iso_varying_string = { git = "https://gitlab.com/everythingfunctional/iso_varying_string.git", tag = "v2.0.0" }
|
||||
strff = { git = "https://gitlab.com/everythingfunctional/strff.git", tag = "v2.0.1" }
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
module leaf_m
|
||||
use iso_varying_string, only: varying_string
|
||||
use strff, only: to_string
|
||||
use tree_m, only: tree_t
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: leaf_t
|
||||
|
||||
type, extends(tree_t) :: leaf_t
|
||||
private
|
||||
integer :: value_
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string => leaf_to_string
|
||||
end type
|
||||
|
||||
interface leaf_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(value_) result(leaf)
|
||||
integer, intent(in) :: value_
|
||||
type(leaf_t) :: leaf
|
||||
|
||||
leaf%value_ = value_
|
||||
end function
|
||||
|
||||
pure function leaf_to_string(self) result(string)
|
||||
class(leaf_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = to_string(self%value_)
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,155 @@
|
|||
module node_m
|
||||
use iso_varying_string, only: &
|
||||
varying_string, assignment(=), operator(//), len, trim, var_str
|
||||
use strff, only: join, split_at, NEWLINE
|
||||
use tree_m, only: tree_t
|
||||
use tree_item_m, only: tree_item_t
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: node_t
|
||||
|
||||
type, extends(tree_t) :: node_t
|
||||
private
|
||||
type(tree_item_t), allocatable :: children(:)
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string
|
||||
end type
|
||||
|
||||
interface node_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
function constructor(children) result(node)
|
||||
type(tree_item_t), intent(in) :: children(:)
|
||||
type(node_t) :: node
|
||||
|
||||
allocate(node%children, source = children)
|
||||
end function
|
||||
|
||||
pure recursive function to_string(self) result(string)
|
||||
class(node_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
type(varying_string) :: blocked
|
||||
type(varying_string), allocatable :: child_strings(:)
|
||||
type(varying_string) :: dashed_line
|
||||
integer :: height_
|
||||
integer :: i
|
||||
type(varying_string), allocatable :: padded_strings(:)
|
||||
type(varying_string) :: pipes
|
||||
integer, allocatable :: widths(:)
|
||||
|
||||
allocate(child_strings, source = [(self%children(i)%to_string(), i = 1, size(self%children))])
|
||||
allocate(widths, source = max_width(child_strings)+1)
|
||||
height_ = maxval(height(child_strings))
|
||||
dashed_line = make_dashes(widths)
|
||||
pipes = join(make_pipe(widths), "")
|
||||
allocate(padded_strings, source = pad_to(child_strings, widths, height_))
|
||||
blocked = join( &
|
||||
[ dashed_line&
|
||||
, pipes &
|
||||
, concat_lines(padded_strings) &
|
||||
], &
|
||||
NEWLINE)
|
||||
string = strip_trailing_space(blocked)
|
||||
end function
|
||||
|
||||
elemental function max_width(tree_string) result(width)
|
||||
type(varying_string), intent(in) :: tree_string
|
||||
integer :: width
|
||||
|
||||
width = maxval(len(split_at(tree_string, NEWLINE)))
|
||||
end function
|
||||
|
||||
elemental function height(tree_string)
|
||||
type(varying_string), intent(in) :: tree_string
|
||||
integer :: height
|
||||
|
||||
height = size(split_at(tree_string, NEWLINE))
|
||||
end function
|
||||
|
||||
elemental function pad_to(string, width, num_lines) result(padded)
|
||||
type(varying_string), intent(in) :: string
|
||||
integer, intent(in) :: width, num_lines
|
||||
type(varying_string) :: padded
|
||||
|
||||
integer :: i
|
||||
|
||||
associate(lines => split_at(string, NEWLINE))
|
||||
associate(padded_lines => pad_line(lines, width))
|
||||
padded = join([padded_lines, [(var_str(repeat(" ", width)), i = 1, num_lines - size(lines))]], NEWLINE)
|
||||
end associate
|
||||
end associate
|
||||
contains
|
||||
elemental function pad_line(line, width) result(padded_line)
|
||||
type(varying_string), intent(in) :: line
|
||||
integer, intent(in) :: width
|
||||
type(varying_string) :: padded_line
|
||||
|
||||
padded_line = line // repeat(" ", width - len(line))
|
||||
end function
|
||||
end function
|
||||
|
||||
pure function make_dashes(widths) result(dashes)
|
||||
integer, intent(in) :: widths(:)
|
||||
type(varying_string) :: dashes
|
||||
|
||||
if (size(widths) == 1) then
|
||||
dashes = make_pipe(widths(1))
|
||||
else
|
||||
associate( &
|
||||
leading_spaces => widths(1)/2 - 1, &
|
||||
trailing_spaces => widths(size(widths)) - widths(size(widths))/2, &
|
||||
total_width => sum(widths))
|
||||
associate(dash_width => total_width - leading_spaces - trailing_spaces)
|
||||
dashes = repeat(" ", leading_spaces) // repeat("-", dash_width) // repeat(" ", trailing_spaces)
|
||||
end associate
|
||||
end associate
|
||||
end if
|
||||
end function
|
||||
|
||||
elemental function make_pipe(width) result(pipe)
|
||||
integer, intent(in) :: width
|
||||
type(varying_string) :: pipe
|
||||
|
||||
pipe = center_in(var_str("|"), width)
|
||||
end function
|
||||
|
||||
pure function center_in(string, width) result(centered)
|
||||
type(varying_string), intent(in) :: string
|
||||
integer, intent(in) :: width
|
||||
type(varying_string) :: centered
|
||||
|
||||
associate(leading_spaces => width/2 - len(string)/2 - 1)
|
||||
associate(trailing_spaces => width - leading_spaces - len(string))
|
||||
centered = repeat(" ", leading_spaces) // string // repeat(" ", trailing_spaces)
|
||||
end associate
|
||||
end associate
|
||||
end function
|
||||
|
||||
pure function concat_lines(strings) result(joined)
|
||||
type(varying_string), intent(in) :: strings(:)
|
||||
type(varying_string) :: joined
|
||||
|
||||
integer :: i, j
|
||||
|
||||
associate(lines => [(split_at(strings(i), NEWLINE), i = 1, size(strings))])
|
||||
associate(num_lines => size(lines) / size(strings))
|
||||
joined = join( &
|
||||
[(join( &
|
||||
[(lines(i), i = j, num_lines*size(strings), num_lines)] &
|
||||
, ""), j = 1, num_lines)], &
|
||||
NEWLINE)
|
||||
end associate
|
||||
end associate
|
||||
end function
|
||||
|
||||
pure function strip_trailing_space(string) result(stripped)
|
||||
type(varying_string), intent(in) :: string
|
||||
type(varying_string) :: stripped
|
||||
|
||||
stripped = join(trim(split_at(string, NEWLINE)), NEWLINE)
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
module tree_item_m
|
||||
use iso_varying_string, only: varying_string
|
||||
use tree_m, only: tree_t
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: tree_item_t
|
||||
|
||||
type :: tree_item_t
|
||||
private
|
||||
class(tree_t), allocatable :: tree
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string
|
||||
end type
|
||||
|
||||
interface tree_item_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
function constructor(tree) result(tree_item)
|
||||
class(tree_t), intent(in) :: tree
|
||||
type(tree_item_t) :: tree_item
|
||||
|
||||
allocate(tree_item%tree, source = tree)
|
||||
end function
|
||||
|
||||
pure recursive function to_string(self) result(string)
|
||||
class(tree_item_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = self%tree%to_string()
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
module tree_m
|
||||
use iso_varying_string, only: varying_string
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: tree_t
|
||||
|
||||
type, abstract :: tree_t
|
||||
contains
|
||||
private
|
||||
procedure(to_string_i), public, deferred :: to_string
|
||||
end type
|
||||
|
||||
abstract interface
|
||||
pure function to_string_i(self) result(string)
|
||||
import :: tree_t, varying_string
|
||||
|
||||
implicit none
|
||||
|
||||
class(tree_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
end function
|
||||
end interface
|
||||
end module
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
program main
|
||||
use circle_m, only: circle_t
|
||||
use iso_varying_string, only: put_line
|
||||
use rectangle_m, only: rectangle_t
|
||||
use shape_list_m, only: shape_list_t
|
||||
use shape_item_m, only: shape_item_t
|
||||
use square_m, only: square_t
|
||||
use triangle_m, only: triangle_t
|
||||
|
||||
implicit none
|
||||
|
||||
type(shape_list_t) :: list
|
||||
|
||||
list = shape_list_t( &
|
||||
shapes = [ &
|
||||
shape_item_t( &
|
||||
shape = square_t( &
|
||||
width = 2.0 &
|
||||
) &
|
||||
), &
|
||||
shape_item_t( &
|
||||
shape = circle_t( &
|
||||
radius = 3.0 &
|
||||
) &
|
||||
), &
|
||||
shape_item_t( &
|
||||
shape = triangle_t( &
|
||||
base = 4.0, &
|
||||
height = 5.0 &
|
||||
) &
|
||||
), &
|
||||
shape_item_t( &
|
||||
shape = rectangle_t( &
|
||||
height = 2.0, &
|
||||
width = 3.0 &
|
||||
) &
|
||||
) &
|
||||
] &
|
||||
)
|
||||
|
||||
call put_line(list%to_string())
|
||||
end program
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
name = "heterogeneous_list"
|
||||
version = "0.1.0"
|
||||
license = "MIT"
|
||||
author = "Brad Richardson"
|
||||
maintainer = "everythingfunctional@protonmail.com"
|
||||
copyright = "2020 Brad Richardson"
|
||||
|
||||
[dependencies]
|
||||
iso_varying_string = { git = "https://gitlab.com/everythingfunctional/iso_varying_string.git", tag = "v2.0.0" }
|
||||
strff = { git = "https://gitlab.com/everythingfunctional/strff.git", tag = "v2.0.1" }
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
module circle_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, to_string, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: circle_t
|
||||
|
||||
type, extends(shape_t) :: circle_t
|
||||
private
|
||||
real :: radius
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string => circle_to_string
|
||||
end type
|
||||
|
||||
interface circle_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(radius) result(circle)
|
||||
real, intent(in) :: radius
|
||||
type(circle_t) :: circle
|
||||
|
||||
circle%radius = radius
|
||||
end function
|
||||
|
||||
pure function circle_to_string(self) result(string)
|
||||
class(circle_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"circle_t(" // NEWLINE &
|
||||
// "radius = " // to_string(self%radius), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
module rectangle_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, to_string, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: rectangle_t
|
||||
|
||||
type, extends(shape_t) :: rectangle_t
|
||||
private
|
||||
real :: height
|
||||
real :: width
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string => rectangle_to_string
|
||||
end type
|
||||
|
||||
interface rectangle_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(height, width) result(rectangle)
|
||||
real, intent(in) :: height
|
||||
real, intent(in) :: width
|
||||
type(rectangle_t) :: rectangle
|
||||
|
||||
rectangle%height = height
|
||||
rectangle%width = width
|
||||
end function
|
||||
|
||||
pure function rectangle_to_string(self) result(string)
|
||||
class(rectangle_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"rectangle_t(" // NEWLINE &
|
||||
// "height = " // to_string(self%height) // "," // NEWLINE &
|
||||
// "width = " // to_string(self%width), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
module shape_item_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: shape_item_t
|
||||
|
||||
type :: shape_item_t
|
||||
private
|
||||
class(shape_t), allocatable :: shape
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string
|
||||
end type
|
||||
|
||||
interface shape_item_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
function constructor(shape) result(shape_item)
|
||||
class(shape_t), intent(in) :: shape
|
||||
type(shape_item_t) :: shape_item
|
||||
|
||||
shape_item%shape = shape
|
||||
end function
|
||||
|
||||
elemental function to_string(self) result(string)
|
||||
class(shape_item_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"shape_item_t(" // NEWLINE &
|
||||
// "shape = " // self%shape%to_string(), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,41 @@
|
|||
module shape_list_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_item_m, only: shape_item_t
|
||||
use strff, only: hanging_indent, indent, join, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: shape_list_t
|
||||
|
||||
type :: shape_list_t
|
||||
private
|
||||
type(shape_item_t), allocatable :: shapes(:)
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string
|
||||
end type
|
||||
|
||||
interface shape_list_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
function constructor(shapes) result(shape_list)
|
||||
type(shape_item_t), intent(in) :: shapes(:)
|
||||
type(shape_list_t) :: shape_list
|
||||
|
||||
allocate(shape_list%shapes, source = shapes)
|
||||
end function
|
||||
|
||||
pure function to_string(self) result(string)
|
||||
class(shape_list_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"shape_list_t(" // NEWLINE &
|
||||
// "shapes = [" // NEWLINE &
|
||||
// indent(join(self%shapes%to_string(), "," // NEWLINE), 4) // NEWLINE &
|
||||
// "]", &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
module shape_m
|
||||
use iso_varying_string, only: varying_string
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: shape_t
|
||||
|
||||
type, abstract :: shape_t
|
||||
contains
|
||||
private
|
||||
procedure(to_string_i), deferred, public :: to_string
|
||||
end type
|
||||
|
||||
abstract interface
|
||||
pure function to_string_i(self) result(string)
|
||||
import :: shape_t, varying_string
|
||||
|
||||
implicit none
|
||||
|
||||
class(shape_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
end function
|
||||
end interface
|
||||
end module
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
module square_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, to_string, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: square_t
|
||||
|
||||
type, extends(shape_t) :: square_t
|
||||
private
|
||||
real :: width
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string => square_to_string
|
||||
end type
|
||||
|
||||
interface square_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(width) result(square)
|
||||
real, intent(in) :: width
|
||||
type(square_t) :: square
|
||||
|
||||
square%width = width
|
||||
end function
|
||||
|
||||
pure function square_to_string(self) result(string)
|
||||
class(square_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"square_t(" // NEWLINE &
|
||||
// "width = " // to_string(self%width), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
module triangle_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, to_string, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: triangle_t
|
||||
|
||||
type, extends(shape_t) :: triangle_t
|
||||
private
|
||||
real :: base
|
||||
real :: height
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string => triangle_to_string
|
||||
end type
|
||||
|
||||
interface triangle_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(base, height) result(triangle)
|
||||
real, intent(in) :: base
|
||||
real, intent(in) :: height
|
||||
type(triangle_t) :: triangle
|
||||
|
||||
triangle%base = base
|
||||
triangle%height = height
|
||||
end function
|
||||
|
||||
pure function triangle_to_string(self) result(string)
|
||||
class(triangle_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"triangle_t(" // NEWLINE &
|
||||
// "base = " // to_string(self%base) // "," // NEWLINE &
|
||||
// "height = " // to_string(self%height), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
program main
|
||||
use circle_m, only: circle_t
|
||||
use iso_varying_string, only: put_line
|
||||
use shape_list_m, only: shape_list_t
|
||||
use shape_item_m, only: shape_item_t
|
||||
use square_m, only: square_t
|
||||
use strff, only: to_string
|
||||
use triangle_m, only: triangle_t
|
||||
|
||||
implicit none
|
||||
|
||||
type(shape_list_t) :: list
|
||||
|
||||
list = shape_list_t( &
|
||||
shapes = [ &
|
||||
shape_item_t( &
|
||||
shape = square_t( &
|
||||
width = 2.0 &
|
||||
) &
|
||||
), &
|
||||
shape_item_t( &
|
||||
shape = circle_t( &
|
||||
radius = 3.0 &
|
||||
) &
|
||||
), &
|
||||
shape_item_t( &
|
||||
shape = triangle_t( &
|
||||
base = 4.0, &
|
||||
height = 5.0 &
|
||||
) &
|
||||
) &
|
||||
] &
|
||||
)
|
||||
|
||||
call put_line(list%to_string())
|
||||
call put_line(to_string(list%total_area()))
|
||||
end program
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
name = "heterogeneous_list"
|
||||
version = "0.1.0"
|
||||
license = "MIT"
|
||||
author = "Brad Richardson"
|
||||
maintainer = "everythingfunctional@protonmail.com"
|
||||
copyright = "2020 Brad Richardson"
|
||||
|
||||
[dependencies]
|
||||
iso_varying_string = { git = "https://gitlab.com/everythingfunctional/iso_varying_string.git", tag = "v2.0.0" }
|
||||
strff = { git = "https://gitlab.com/everythingfunctional/strff.git", tag = "v2.0.1" }
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
module circle_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, to_string, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: circle_t
|
||||
|
||||
type, extends(shape_t) :: circle_t
|
||||
private
|
||||
real :: radius
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string => circle_to_string
|
||||
procedure, public :: area
|
||||
end type
|
||||
|
||||
interface circle_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(radius) result(circle)
|
||||
real, intent(in) :: radius
|
||||
type(circle_t) :: circle
|
||||
|
||||
circle%radius = radius
|
||||
end function
|
||||
|
||||
pure function circle_to_string(self) result(string)
|
||||
class(circle_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"circle_t(" // NEWLINE &
|
||||
// "radius = " // to_string(self%radius), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
|
||||
pure function area(self)
|
||||
class(circle_t), intent(in) :: self
|
||||
real :: area
|
||||
|
||||
area = 3.1415 * self%radius**2
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
module shape_item_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: shape_item_t
|
||||
|
||||
type :: shape_item_t
|
||||
private
|
||||
class(shape_t), allocatable :: shape
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string
|
||||
procedure, public :: area
|
||||
end type
|
||||
|
||||
interface shape_item_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
function constructor(shape) result(shape_item)
|
||||
class(shape_t), intent(in) :: shape
|
||||
type(shape_item_t) :: shape_item
|
||||
|
||||
shape_item%shape = shape
|
||||
end function
|
||||
|
||||
elemental function to_string(self) result(string)
|
||||
class(shape_item_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"shape_item_t(" // NEWLINE &
|
||||
// "shape = " // self%shape%to_string(), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
|
||||
elemental function area(self)
|
||||
class(shape_item_t), intent(in) :: self
|
||||
real :: area
|
||||
|
||||
area = self%shape%area()
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,49 @@
|
|||
module shape_list_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_item_m, only: shape_item_t
|
||||
use strff, only: hanging_indent, indent, join, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: shape_list_t
|
||||
|
||||
type :: shape_list_t
|
||||
private
|
||||
type(shape_item_t), allocatable :: shapes(:)
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string
|
||||
procedure, public :: total_area
|
||||
end type
|
||||
|
||||
interface shape_list_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
function constructor(shapes) result(shape_list)
|
||||
type(shape_item_t), intent(in) :: shapes(:)
|
||||
type(shape_list_t) :: shape_list
|
||||
|
||||
allocate(shape_list%shapes, source = shapes)
|
||||
end function
|
||||
|
||||
pure function to_string(self) result(string)
|
||||
class(shape_list_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"shape_list_t(" // NEWLINE &
|
||||
// "shapes = [" // NEWLINE &
|
||||
// indent(join(self%shapes%to_string(), "," // NEWLINE), 4) // NEWLINE &
|
||||
// "]", &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
|
||||
pure function total_area(self)
|
||||
class(shape_list_t), intent(in) :: self
|
||||
real :: total_area
|
||||
|
||||
total_area = sum(self%shapes%area())
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
module shape_m
|
||||
use iso_varying_string, only: varying_string
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: shape_t
|
||||
|
||||
type, abstract :: shape_t
|
||||
contains
|
||||
private
|
||||
procedure(to_string_i), deferred, public :: to_string
|
||||
procedure(area_i), deferred, public :: area
|
||||
end type
|
||||
|
||||
abstract interface
|
||||
pure function to_string_i(self) result(string)
|
||||
import :: shape_t, varying_string
|
||||
|
||||
implicit none
|
||||
|
||||
class(shape_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
end function
|
||||
|
||||
pure function area_i(self) result(area)
|
||||
import :: shape_t
|
||||
|
||||
implicit none
|
||||
|
||||
class(shape_t), intent(in) :: self
|
||||
real :: area
|
||||
end function
|
||||
end interface
|
||||
end module
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
module square_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, to_string, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: square_t
|
||||
|
||||
type, extends(shape_t) :: square_t
|
||||
private
|
||||
real :: width
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string => square_to_string
|
||||
procedure, public :: area
|
||||
end type
|
||||
|
||||
interface square_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(width) result(square)
|
||||
real, intent(in) :: width
|
||||
type(square_t) :: square
|
||||
|
||||
square%width = width
|
||||
end function
|
||||
|
||||
pure function square_to_string(self) result(string)
|
||||
class(square_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"square_t(" // NEWLINE &
|
||||
// "width = " // to_string(self%width), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
|
||||
pure function area(self)
|
||||
class(square_t), intent(in) :: self
|
||||
real :: area
|
||||
|
||||
area = self%width**2
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,51 @@
|
|||
module triangle_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, to_string, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: triangle_t
|
||||
|
||||
type, extends(shape_t) :: triangle_t
|
||||
private
|
||||
real :: base
|
||||
real :: height
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string => triangle_to_string
|
||||
procedure, public :: area
|
||||
end type
|
||||
|
||||
interface triangle_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(base, height) result(triangle)
|
||||
real, intent(in) :: base
|
||||
real, intent(in) :: height
|
||||
type(triangle_t) :: triangle
|
||||
|
||||
triangle%base = base
|
||||
triangle%height = height
|
||||
end function
|
||||
|
||||
pure function triangle_to_string(self) result(string)
|
||||
class(triangle_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"triangle_t(" // NEWLINE &
|
||||
// "base = " // to_string(self%base) // "," // NEWLINE &
|
||||
// "height = " // to_string(self%height), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
|
||||
pure function area(self)
|
||||
class(triangle_t), intent(in) :: self
|
||||
real :: area
|
||||
|
||||
area = (self%base * self%height) / 2.0
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,120 @@
|
|||
module integer_list_m
|
||||
implicit none
|
||||
private
|
||||
public :: integer_list_t, visitor_t
|
||||
|
||||
type :: list_node_t
|
||||
private
|
||||
integer :: val
|
||||
type(list_node_t), pointer :: next => null()
|
||||
end type
|
||||
|
||||
type :: integer_list_t
|
||||
private
|
||||
type(list_node_t), pointer :: head => null()
|
||||
contains
|
||||
private
|
||||
procedure, public :: prepend
|
||||
procedure, public :: foreach
|
||||
end type
|
||||
|
||||
type, abstract :: visitor_t
|
||||
contains
|
||||
private
|
||||
procedure(visit_i), deferred, public :: visit
|
||||
end type
|
||||
|
||||
abstract interface
|
||||
subroutine visit_i(self, item)
|
||||
import visitor_t
|
||||
implicit none
|
||||
class(visitor_t), intent(inout) :: self
|
||||
integer, intent(inout) :: item
|
||||
end subroutine
|
||||
end interface
|
||||
contains
|
||||
subroutine prepend(self, item)
|
||||
class(integer_list_t), intent(inout) :: self
|
||||
integer, intent(in) :: item
|
||||
|
||||
type(list_node_t), pointer :: new
|
||||
|
||||
if (associated(self%head)) then
|
||||
allocate(new)
|
||||
new%val = item
|
||||
new%next => self%head
|
||||
self%head => new
|
||||
else
|
||||
allocate(self%head)
|
||||
self%head%val = item
|
||||
end if
|
||||
end subroutine
|
||||
|
||||
subroutine foreach(self, visitor)
|
||||
class(integer_list_t), intent(inout) :: self
|
||||
class(visitor_t), intent(inout) :: visitor
|
||||
|
||||
type(list_node_t), pointer :: cursor
|
||||
|
||||
cursor => self%head
|
||||
do while (associated(cursor))
|
||||
call visitor%visit(cursor%val)
|
||||
cursor => cursor%next
|
||||
end do
|
||||
end subroutine
|
||||
end module
|
||||
|
||||
module list_operator_m
|
||||
use integer_list_m, only: visitor_t
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: printer_t, squarer_t
|
||||
|
||||
type, extends(visitor_t) :: printer_t
|
||||
contains
|
||||
private
|
||||
procedure, public :: visit => printer_visit
|
||||
end type
|
||||
|
||||
type, extends(visitor_t) :: squarer_t
|
||||
contains
|
||||
private
|
||||
procedure, public :: visit => squarer_visit
|
||||
end type
|
||||
contains
|
||||
subroutine printer_visit(self, item)
|
||||
class(printer_t), intent(inout) :: self
|
||||
integer, intent(inout) :: item
|
||||
|
||||
print *, item
|
||||
end subroutine
|
||||
|
||||
subroutine squarer_visit(self, item)
|
||||
class(squarer_t), intent(inout) :: self
|
||||
integer, intent(inout) :: item
|
||||
|
||||
item = item*item
|
||||
end subroutine
|
||||
end module
|
||||
|
||||
program main
|
||||
use integer_list_m, only: integer_list_t
|
||||
use list_operator_m, only: printer_t, squarer_t
|
||||
|
||||
implicit none
|
||||
|
||||
type(integer_list_t) :: list
|
||||
type(printer_t) :: printer
|
||||
type(squarer_t) :: squarer
|
||||
|
||||
call list%prepend(2)
|
||||
call list%prepend(3)
|
||||
call list%prepend(5)
|
||||
|
||||
call list%foreach(printer)
|
||||
|
||||
call list%foreach(squarer)
|
||||
|
||||
call list%foreach(printer)
|
||||
end program
|
||||
|
|
@ -0,0 +1,146 @@
|
|||
module integer_list_m
|
||||
implicit none
|
||||
private
|
||||
public :: integer_list_t, visitor_t
|
||||
|
||||
type :: list_node_t
|
||||
private
|
||||
integer :: val
|
||||
type(list_node_t), pointer :: next => null()
|
||||
end type
|
||||
|
||||
type :: integer_list_t
|
||||
private
|
||||
type(list_node_t), pointer :: head => null()
|
||||
contains
|
||||
private
|
||||
procedure, public :: prepend
|
||||
procedure, public :: foreach
|
||||
end type
|
||||
|
||||
type, abstract :: visitor_t
|
||||
contains
|
||||
private
|
||||
procedure(visit_i), deferred, public :: visit
|
||||
end type
|
||||
|
||||
abstract interface
|
||||
subroutine visit_i(self, item)
|
||||
import visitor_t
|
||||
implicit none
|
||||
class(visitor_t), intent(inout) :: self
|
||||
integer, intent(inout) :: item
|
||||
end subroutine
|
||||
end interface
|
||||
contains
|
||||
subroutine prepend(self, item)
|
||||
class(integer_list_t), intent(inout) :: self
|
||||
integer, intent(in) :: item
|
||||
|
||||
type(list_node_t), pointer :: new
|
||||
|
||||
if (associated(self%head)) then
|
||||
allocate(new)
|
||||
new%val = item
|
||||
new%next => self%head
|
||||
self%head => new
|
||||
else
|
||||
allocate(self%head)
|
||||
self%head%val = item
|
||||
end if
|
||||
end subroutine
|
||||
|
||||
subroutine foreach(self, visitor)
|
||||
class(integer_list_t), intent(inout) :: self
|
||||
class(visitor_t), intent(inout) :: visitor
|
||||
|
||||
type(list_node_t), pointer :: cursor
|
||||
|
||||
cursor => self%head
|
||||
do while (associated(cursor))
|
||||
call visitor%visit(cursor%val)
|
||||
cursor => cursor%next
|
||||
end do
|
||||
end subroutine
|
||||
end module
|
||||
|
||||
module list_operator_m
|
||||
use integer_list_m, only: visitor_t
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: printer_t, squarer_t, summer_t
|
||||
|
||||
type, extends(visitor_t) :: printer_t
|
||||
contains
|
||||
private
|
||||
procedure, public :: visit => printer_visit
|
||||
end type
|
||||
|
||||
type, extends(visitor_t) :: squarer_t
|
||||
contains
|
||||
private
|
||||
procedure, public :: visit => squarer_visit
|
||||
end type
|
||||
|
||||
type, extends(visitor_t) :: summer_t
|
||||
private
|
||||
integer :: total = 0
|
||||
contains
|
||||
private
|
||||
procedure, public :: visit => summer_visit
|
||||
procedure, public :: get_sum
|
||||
end type
|
||||
contains
|
||||
subroutine printer_visit(self, item)
|
||||
class(printer_t), intent(inout) :: self
|
||||
integer, intent(inout) :: item
|
||||
|
||||
print *, item
|
||||
end subroutine
|
||||
|
||||
subroutine squarer_visit(self, item)
|
||||
class(squarer_t), intent(inout) :: self
|
||||
integer, intent(inout) :: item
|
||||
|
||||
item = item*item
|
||||
end subroutine
|
||||
|
||||
subroutine summer_visit(self, item)
|
||||
class(summer_t), intent(inout) :: self
|
||||
integer, intent(inout) :: item
|
||||
|
||||
self%total = self%total + item
|
||||
end subroutine
|
||||
|
||||
pure integer function get_sum(self)
|
||||
class(summer_t), intent(in) :: self
|
||||
|
||||
get_sum = self%total
|
||||
end function
|
||||
end module
|
||||
|
||||
program main
|
||||
use integer_list_m, only: integer_list_t
|
||||
use list_operator_m, only: printer_t, squarer_t, summer_t
|
||||
|
||||
implicit none
|
||||
|
||||
type(integer_list_t) :: list
|
||||
type(printer_t) :: printer
|
||||
type(squarer_t) :: squarer
|
||||
type(summer_t) :: summer
|
||||
|
||||
call list%prepend(2)
|
||||
call list%prepend(3)
|
||||
call list%prepend(5)
|
||||
|
||||
call list%foreach(printer)
|
||||
|
||||
call list%foreach(squarer)
|
||||
|
||||
call list%foreach(printer)
|
||||
|
||||
call list%foreach(summer)
|
||||
print *, summer%get_sum()
|
||||
end program
|
||||
|
|
@ -0,0 +1,147 @@
|
|||
module integer_list_m
|
||||
implicit none
|
||||
private
|
||||
public :: integer_list_t, visitor_t
|
||||
|
||||
type :: list_node_t
|
||||
private
|
||||
integer :: val
|
||||
type(list_node_t), pointer :: next => null()
|
||||
end type
|
||||
|
||||
type :: integer_list_t
|
||||
private
|
||||
type(list_node_t), pointer :: head => null()
|
||||
contains
|
||||
private
|
||||
procedure, public :: prepend
|
||||
procedure, public :: foreach
|
||||
end type
|
||||
|
||||
type, abstract :: visitor_t
|
||||
contains
|
||||
private
|
||||
procedure(visit_i), deferred, public :: visit
|
||||
end type
|
||||
|
||||
abstract interface
|
||||
subroutine visit_i(self, item)
|
||||
import visitor_t
|
||||
implicit none
|
||||
class(visitor_t), intent(inout) :: self
|
||||
integer, intent(inout) :: item
|
||||
end subroutine
|
||||
end interface
|
||||
contains
|
||||
subroutine prepend(self, item)
|
||||
class(integer_list_t), intent(inout) :: self
|
||||
integer, intent(in) :: item
|
||||
|
||||
type(list_node_t), pointer :: new
|
||||
|
||||
if (associated(self%head)) then
|
||||
allocate(new)
|
||||
new%val = item
|
||||
new%next => self%head
|
||||
self%head => new
|
||||
else
|
||||
allocate(self%head)
|
||||
self%head%val = item
|
||||
end if
|
||||
end subroutine
|
||||
|
||||
subroutine foreach(self, visitor)
|
||||
class(integer_list_t), intent(inout) :: self
|
||||
class(visitor_t), intent(inout) :: visitor
|
||||
|
||||
type(list_node_t), pointer :: cursor
|
||||
|
||||
cursor => self%head
|
||||
do while (associated(cursor))
|
||||
call visitor%visit(cursor%val)
|
||||
cursor => cursor%next
|
||||
end do
|
||||
end subroutine
|
||||
end module
|
||||
|
||||
module list_operator_m
|
||||
use integer_list_m, only: visitor_t
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: printer_t, squarer_t, summer_t
|
||||
|
||||
type, extends(visitor_t) :: printer_t
|
||||
contains
|
||||
private
|
||||
procedure, public :: visit => printer_visit
|
||||
end type
|
||||
|
||||
type, extends(visitor_t) :: squarer_t
|
||||
contains
|
||||
private
|
||||
procedure, public :: visit => squarer_visit
|
||||
end type
|
||||
|
||||
type, extends(visitor_t) :: summer_t
|
||||
private
|
||||
integer :: total = 0
|
||||
contains
|
||||
private
|
||||
procedure, public :: visit => summer_visit
|
||||
procedure, public :: get_sum
|
||||
end type
|
||||
contains
|
||||
subroutine printer_visit(self, item)
|
||||
class(printer_t), intent(inout) :: self
|
||||
integer, intent(inout) :: item
|
||||
|
||||
print *, item
|
||||
end subroutine
|
||||
|
||||
subroutine squarer_visit(self, item)
|
||||
class(squarer_t), intent(inout) :: self
|
||||
integer, intent(inout) :: item
|
||||
|
||||
item = item*item
|
||||
end subroutine
|
||||
|
||||
subroutine summer_visit(self, item)
|
||||
class(summer_t), intent(inout) :: self
|
||||
integer, intent(inout) :: item
|
||||
|
||||
self%total = self%total + item
|
||||
end subroutine
|
||||
|
||||
pure function get_sum(self) result(total)
|
||||
class(summer_t), intent(in) :: self
|
||||
integer :: total
|
||||
|
||||
total = self%total
|
||||
end function
|
||||
end module
|
||||
|
||||
program main
|
||||
use integer_list_m, only: integer_list_t
|
||||
use list_operator_m, only: printer_t, squarer_t, summer_t
|
||||
|
||||
implicit none
|
||||
|
||||
type(integer_list_t) :: list
|
||||
type(printer_t) :: printer
|
||||
type(squarer_t) :: squarer
|
||||
type(summer_t) :: summer
|
||||
|
||||
call list%prepend(2)
|
||||
call list%prepend(3)
|
||||
call list%prepend(5)
|
||||
|
||||
call list%foreach(printer)
|
||||
|
||||
call list%foreach(squarer)
|
||||
|
||||
call list%foreach(printer)
|
||||
|
||||
call list%foreach(summer)
|
||||
print *, summer%get_sum()
|
||||
end program
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
program main
|
||||
use circle_m, only: circle_t
|
||||
use iso_varying_string, only: put_line
|
||||
use shape_list_m, only: shape_list_t
|
||||
use shape_item_m, only: shape_item_t
|
||||
use square_m, only: square_t
|
||||
use triangle_m, only: triangle_t
|
||||
|
||||
implicit none
|
||||
|
||||
type(shape_list_t) :: list
|
||||
type(shape_list_t) :: duplicated_list
|
||||
|
||||
list = shape_list_t( &
|
||||
shapes = [ &
|
||||
shape_item_t( &
|
||||
shape = square_t( &
|
||||
width = 2.0 &
|
||||
) &
|
||||
), &
|
||||
shape_item_t( &
|
||||
shape = circle_t( &
|
||||
radius = 3.0 &
|
||||
) &
|
||||
), &
|
||||
shape_item_t( &
|
||||
shape = triangle_t( &
|
||||
base = 4.0, &
|
||||
height = 5.0 &
|
||||
) &
|
||||
) &
|
||||
] &
|
||||
)
|
||||
|
||||
call put_line(list%to_string())
|
||||
|
||||
duplicated_list = list // list
|
||||
|
||||
call put_line(duplicated_list%to_string())
|
||||
end program
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
name = "heterogeneous_list"
|
||||
version = "0.1.0"
|
||||
license = "MIT"
|
||||
author = "Brad Richardson"
|
||||
maintainer = "everythingfunctional@protonmail.com"
|
||||
copyright = "2020 Brad Richardson"
|
||||
|
||||
[dependencies]
|
||||
iso_varying_string = { git = "https://gitlab.com/everythingfunctional/iso_varying_string.git", tag = "v2.0.0" }
|
||||
strff = { git = "https://gitlab.com/everythingfunctional/strff.git", tag = "v2.0.1" }
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
module circle_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, to_string, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: circle_t
|
||||
|
||||
type, extends(shape_t) :: circle_t
|
||||
private
|
||||
real :: radius
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string => circle_to_string
|
||||
end type
|
||||
|
||||
interface circle_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(radius) result(circle)
|
||||
real, intent(in) :: radius
|
||||
type(circle_t) :: circle
|
||||
|
||||
circle%radius = radius
|
||||
end function
|
||||
|
||||
pure function circle_to_string(self) result(string)
|
||||
class(circle_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"circle_t(" // NEWLINE &
|
||||
// "radius = " // to_string(self%radius), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
module shape_item_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: shape_item_t
|
||||
|
||||
type :: shape_item_t
|
||||
private
|
||||
class(shape_t), allocatable :: shape
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string
|
||||
end type
|
||||
|
||||
interface shape_item_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
function constructor(shape) result(shape_item)
|
||||
class(shape_t), intent(in) :: shape
|
||||
type(shape_item_t) :: shape_item
|
||||
|
||||
shape_item%shape = shape
|
||||
end function
|
||||
|
||||
elemental function to_string(self) result(string)
|
||||
class(shape_item_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"shape_item_t(" // NEWLINE &
|
||||
// "shape = " // self%shape%to_string(), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,51 @@
|
|||
module shape_list_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_item_m, only: shape_item_t
|
||||
use strff, only: hanging_indent, indent, join, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: shape_list_t
|
||||
|
||||
type :: shape_list_t
|
||||
private
|
||||
type(shape_item_t), allocatable :: shapes(:)
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string
|
||||
procedure :: concat
|
||||
generic, public :: operator(//) => concat
|
||||
end type
|
||||
|
||||
interface shape_list_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
function constructor(shapes) result(shape_list)
|
||||
type(shape_item_t), intent(in) :: shapes(:)
|
||||
type(shape_list_t) :: shape_list
|
||||
|
||||
allocate(shape_list%shapes, source = shapes)
|
||||
end function
|
||||
|
||||
pure function to_string(self) result(string)
|
||||
class(shape_list_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"shape_list_t(" // NEWLINE &
|
||||
// "shapes = [" // NEWLINE &
|
||||
// indent(join(self%shapes%to_string(), "," // NEWLINE), 4) // NEWLINE &
|
||||
// "]", &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
|
||||
function concat(lhs, rhs) result(combined)
|
||||
class(shape_list_t), intent(in) :: lhs
|
||||
type(shape_list_t), intent(in) :: rhs
|
||||
type(shape_list_t) :: combined
|
||||
|
||||
allocate(combined%shapes, source = [lhs%shapes, rhs%shapes])
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
module shape_m
|
||||
use iso_varying_string, only: varying_string
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: shape_t
|
||||
|
||||
type, abstract :: shape_t
|
||||
contains
|
||||
private
|
||||
procedure(to_string_i), deferred, public :: to_string
|
||||
end type
|
||||
|
||||
abstract interface
|
||||
pure function to_string_i(self) result(string)
|
||||
import :: shape_t, varying_string
|
||||
|
||||
implicit none
|
||||
|
||||
class(shape_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
end function
|
||||
end interface
|
||||
end module
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
module square_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, to_string, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: square_t
|
||||
|
||||
type, extends(shape_t) :: square_t
|
||||
private
|
||||
real :: width
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string => square_to_string
|
||||
end type
|
||||
|
||||
interface square_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(width) result(square)
|
||||
real, intent(in) :: width
|
||||
type(square_t) :: square
|
||||
|
||||
square%width = width
|
||||
end function
|
||||
|
||||
pure function square_to_string(self) result(string)
|
||||
class(square_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"square_t(" // NEWLINE &
|
||||
// "width = " // to_string(self%width), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
module triangle_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, to_string, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: triangle_t
|
||||
|
||||
type, extends(shape_t) :: triangle_t
|
||||
private
|
||||
real :: base
|
||||
real :: height
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string => triangle_to_string
|
||||
end type
|
||||
|
||||
interface triangle_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(base, height) result(triangle)
|
||||
real, intent(in) :: base
|
||||
real, intent(in) :: height
|
||||
type(triangle_t) :: triangle
|
||||
|
||||
triangle%base = base
|
||||
triangle%height = height
|
||||
end function
|
||||
|
||||
pure function triangle_to_string(self) result(string)
|
||||
class(triangle_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"triangle_t(" // NEWLINE &
|
||||
// "base = " // to_string(self%base) // "," // NEWLINE &
|
||||
// "height = " // to_string(self%height), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,49 @@
|
|||
program main
|
||||
use circle_m, only: circle_t
|
||||
use filter_out_area_greater_than_m, only: filter_out_area_greater_than_t
|
||||
use filter_out_curves_m, only: filter_out_curves_t
|
||||
use iso_varying_string, only: put_line
|
||||
use shape_list_m, only: shape_list_t
|
||||
use shape_item_m, only: shape_item_t
|
||||
use square_m, only: square_t
|
||||
use strff, only: to_string
|
||||
use triangle_m, only: triangle_t
|
||||
|
||||
implicit none
|
||||
|
||||
type(shape_list_t) :: list
|
||||
type(shape_list_t) :: duplicated_list
|
||||
type(shape_list_t) :: filtered
|
||||
|
||||
list = shape_list_t( &
|
||||
shapes = [ &
|
||||
shape_item_t( &
|
||||
shape = square_t( &
|
||||
width = 2.0 &
|
||||
) &
|
||||
), &
|
||||
shape_item_t( &
|
||||
shape = circle_t( &
|
||||
radius = 3.0 &
|
||||
) &
|
||||
), &
|
||||
shape_item_t( &
|
||||
shape = triangle_t( &
|
||||
base = 4.0, &
|
||||
height = 5.0 &
|
||||
) &
|
||||
) &
|
||||
] &
|
||||
)
|
||||
|
||||
call put_line(list%to_string())
|
||||
call put_line(to_string(list%total_area()))
|
||||
|
||||
duplicated_list = (list*2.0) // (list*0.3)
|
||||
|
||||
call put_line(duplicated_list%to_string())
|
||||
|
||||
filtered = duplicated_list%filtered_by(filter_out_area_greater_than_t(2.0))
|
||||
|
||||
call put_line(filtered%to_string())
|
||||
end program
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
name = "heterogeneous_list"
|
||||
version = "0.1.0"
|
||||
license = "MIT"
|
||||
author = "Brad Richardson"
|
||||
maintainer = "everythingfunctional@protonmail.com"
|
||||
copyright = "2020 Brad Richardson"
|
||||
|
||||
[dependencies]
|
||||
iso_varying_string = { git = "https://gitlab.com/everythingfunctional/iso_varying_string.git", tag = "v2.0.0" }
|
||||
strff = { git = "https://gitlab.com/everythingfunctional/strff.git", tag = "v2.0.1" }
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
module circle_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, to_string, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: circle_t
|
||||
|
||||
type, extends(shape_t) :: circle_t
|
||||
private
|
||||
real :: radius
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string => circle_to_string
|
||||
procedure, public :: scale
|
||||
procedure, public :: area
|
||||
procedure, public :: has_curves
|
||||
end type
|
||||
|
||||
interface circle_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(radius) result(circle)
|
||||
real, intent(in) :: radius
|
||||
type(circle_t) :: circle
|
||||
|
||||
circle%radius = radius
|
||||
end function
|
||||
|
||||
pure function circle_to_string(self) result(string)
|
||||
class(circle_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"circle_t(" // NEWLINE &
|
||||
// "radius = " // to_string(self%radius), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
|
||||
function scale(self, factor) result(scaled)
|
||||
class(circle_t), intent(in) :: self
|
||||
real, intent(in) :: factor
|
||||
class(shape_t), allocatable :: scaled
|
||||
|
||||
allocate(scaled, source = circle_t(radius = self%radius * factor))
|
||||
end function
|
||||
|
||||
pure function area(self)
|
||||
class(circle_t), intent(in) :: self
|
||||
real :: area
|
||||
|
||||
area = 3.1415 * self%radius**2
|
||||
end function
|
||||
|
||||
pure function has_curves(self)
|
||||
class(circle_t), intent(in) :: self
|
||||
logical :: has_curves
|
||||
|
||||
has_curves = .true.
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
module filter_out_area_greater_than_m
|
||||
use shape_m, only: shape_t
|
||||
use shape_filterer_m, only: shape_filterer_t
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: filter_out_area_greater_than_t
|
||||
|
||||
type, extends(shape_filterer_t) :: filter_out_area_greater_than_t
|
||||
private
|
||||
real :: limit
|
||||
contains
|
||||
private
|
||||
procedure, public :: matches
|
||||
end type
|
||||
|
||||
interface filter_out_area_greater_than_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(limit) result(filter)
|
||||
real, intent(in) :: limit
|
||||
type(filter_out_area_greater_than_t) :: filter
|
||||
|
||||
filter%limit = limit
|
||||
end function
|
||||
|
||||
pure function matches(self, shape)
|
||||
class(filter_out_area_greater_than_t), intent(in) :: self
|
||||
class(shape_t), intent(in) :: shape
|
||||
logical :: matches
|
||||
|
||||
matches = shape%area() < self%limit
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
module filter_out_curves_m
|
||||
use shape_m, only: shape_t
|
||||
use shape_filterer_m, only: shape_filterer_t
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: filter_out_curves_t
|
||||
|
||||
type, extends(shape_filterer_t) :: filter_out_curves_t
|
||||
contains
|
||||
private
|
||||
procedure, public :: matches
|
||||
end type
|
||||
contains
|
||||
pure function matches(self, shape)
|
||||
class(filter_out_curves_t), intent(in) :: self
|
||||
class(shape_t), intent(in) :: shape
|
||||
logical :: matches
|
||||
|
||||
matches = .not. shape%has_curves()
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
module shape_filterer_m
|
||||
use shape_m, only: shape_t
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: shape_filterer_t
|
||||
|
||||
type, abstract :: shape_filterer_t
|
||||
contains
|
||||
private
|
||||
procedure(matches_i), deferred, public :: matches
|
||||
end type
|
||||
|
||||
abstract interface
|
||||
pure function matches_i(self, shape) result(matches)
|
||||
import :: shape_t, shape_filterer_t
|
||||
|
||||
implicit none
|
||||
|
||||
class(shape_filterer_t), intent(in) :: self
|
||||
class(shape_t), intent(in) :: shape
|
||||
logical :: matches
|
||||
end function
|
||||
end interface
|
||||
end module
|
||||
|
|
@ -0,0 +1,67 @@
|
|||
module shape_item_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use shape_filterer_m, only: shape_filterer_t
|
||||
use strff, only: hanging_indent, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: shape_item_t
|
||||
|
||||
type :: shape_item_t
|
||||
private
|
||||
class(shape_t), allocatable :: shape
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string
|
||||
procedure :: scale
|
||||
generic, public :: operator(*) => scale
|
||||
procedure, public :: area
|
||||
procedure, public :: satisfies
|
||||
end type
|
||||
|
||||
interface shape_item_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
function constructor(shape) result(shape_item)
|
||||
class(shape_t), intent(in) :: shape
|
||||
type(shape_item_t) :: shape_item
|
||||
|
||||
allocate(shape_item%shape, source = shape)
|
||||
end function
|
||||
|
||||
elemental function to_string(self) result(string)
|
||||
class(shape_item_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"shape_item_t(" // NEWLINE &
|
||||
// "shape = " // self%shape%to_string(), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
|
||||
impure elemental function scale(self, factor) result(scaled)
|
||||
class(shape_item_t), intent(in) :: self
|
||||
real, intent(in) :: factor
|
||||
type(shape_item_t) :: scaled
|
||||
|
||||
allocate(scaled%shape, source = self%shape * factor)
|
||||
end function
|
||||
|
||||
elemental function area(self)
|
||||
class(shape_item_t), intent(in) :: self
|
||||
real :: area
|
||||
|
||||
area = self%shape%area()
|
||||
end function
|
||||
|
||||
elemental function satisfies(self, filterer)
|
||||
class(shape_item_t), intent(in) :: self
|
||||
class(shape_filterer_t), intent(in) :: filterer
|
||||
logical :: satisfies
|
||||
|
||||
satisfies = filterer%matches(self%shape)
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,79 @@
|
|||
module shape_list_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_filterer_m, only: shape_filterer_t
|
||||
use shape_item_m, only: shape_item_t
|
||||
use strff, only: hanging_indent, indent, join, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: shape_list_t
|
||||
|
||||
type :: shape_list_t
|
||||
private
|
||||
type(shape_item_t), allocatable :: shapes(:)
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string
|
||||
procedure :: concat
|
||||
generic, public :: operator(//) => concat
|
||||
procedure :: scale
|
||||
generic, public :: operator(*) => scale
|
||||
procedure, public :: total_area
|
||||
procedure, public :: filtered_by
|
||||
end type
|
||||
|
||||
interface shape_list_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
function constructor(shapes) result(shape_list)
|
||||
type(shape_item_t), intent(in) :: shapes(:)
|
||||
type(shape_list_t) :: shape_list
|
||||
|
||||
allocate(shape_list%shapes, source = shapes)
|
||||
end function
|
||||
|
||||
pure function to_string(self) result(string)
|
||||
class(shape_list_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"shape_list_t(" // NEWLINE &
|
||||
// "shapes = [" // NEWLINE &
|
||||
// indent(join(self%shapes%to_string(), "," // NEWLINE), 4) // NEWLINE &
|
||||
// "]", &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
|
||||
function concat(lhs, rhs) result(combined)
|
||||
class(shape_list_t), intent(in) :: lhs
|
||||
type(shape_list_t), intent(in) :: rhs
|
||||
type(shape_list_t) :: combined
|
||||
|
||||
allocate(combined%shapes, source = [lhs%shapes, rhs%shapes])
|
||||
end function
|
||||
|
||||
function scale(self, factor) result(scaled)
|
||||
class(shape_list_t), intent(in) :: self
|
||||
real, intent(in) :: factor
|
||||
type(shape_list_t) :: scaled
|
||||
|
||||
allocate(scaled%shapes, source = self%shapes * factor)
|
||||
end function
|
||||
|
||||
pure function total_area(self)
|
||||
class(shape_list_t), intent(in) :: self
|
||||
real :: total_area
|
||||
|
||||
total_area = sum(self%shapes%area())
|
||||
end function
|
||||
|
||||
function filtered_by(self, filterer) result(filtered)
|
||||
class(shape_list_t), intent(in) :: self
|
||||
class(shape_filterer_t), intent(in) :: filterer
|
||||
type(shape_list_t) :: filtered
|
||||
|
||||
allocate(filtered%shapes, source = pack(self%shapes, mask = self%shapes%satisfies(filterer)))
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,56 @@
|
|||
module shape_m
|
||||
use iso_varying_string, only: varying_string
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: shape_t
|
||||
|
||||
type, abstract :: shape_t
|
||||
contains
|
||||
private
|
||||
procedure(to_string_i), deferred, public :: to_string
|
||||
procedure(scale_i), deferred, public :: scale
|
||||
generic, public :: operator(*) => scale
|
||||
procedure(area_i), deferred, public :: area
|
||||
procedure(has_curves_i), deferred, public :: has_curves
|
||||
end type
|
||||
|
||||
abstract interface
|
||||
pure function to_string_i(self) result(string)
|
||||
import :: shape_t, varying_string
|
||||
|
||||
implicit none
|
||||
|
||||
class(shape_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
end function
|
||||
|
||||
function scale_i(self, factor) result(scaled)
|
||||
import :: shape_t
|
||||
|
||||
implicit none
|
||||
|
||||
class(shape_t), intent(in) :: self
|
||||
real, intent(in) :: factor
|
||||
class(shape_t), allocatable :: scaled
|
||||
end function
|
||||
|
||||
pure function area_i(self) result(area)
|
||||
import :: shape_t
|
||||
|
||||
implicit none
|
||||
|
||||
class(shape_t), intent(in) :: self
|
||||
real :: area
|
||||
end function
|
||||
|
||||
pure function has_curves_i(self) result(has_curves)
|
||||
import :: shape_t
|
||||
|
||||
implicit none
|
||||
|
||||
class(shape_t), intent(in) :: self
|
||||
logical :: has_curves
|
||||
end function
|
||||
end interface
|
||||
end module
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
module square_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, to_string, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: square_t
|
||||
|
||||
type, extends(shape_t) :: square_t
|
||||
private
|
||||
real :: width
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string => square_to_string
|
||||
procedure, public :: scale
|
||||
procedure, public :: area
|
||||
procedure, public :: has_curves
|
||||
end type
|
||||
|
||||
interface square_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(width) result(square)
|
||||
real, intent(in) :: width
|
||||
type(square_t) :: square
|
||||
|
||||
square%width = width
|
||||
end function
|
||||
|
||||
pure function square_to_string(self) result(string)
|
||||
class(square_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"square_t(" // NEWLINE &
|
||||
// "width = " // to_string(self%width), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
|
||||
function scale(self, factor) result(scaled)
|
||||
class(square_t), intent(in) :: self
|
||||
real, intent(in) :: factor
|
||||
class(shape_t), allocatable :: scaled
|
||||
|
||||
allocate(scaled, source = square_t(width = self%width * factor))
|
||||
end function
|
||||
|
||||
pure function area(self)
|
||||
class(square_t), intent(in) :: self
|
||||
real :: area
|
||||
|
||||
area = self%width**2
|
||||
end function
|
||||
|
||||
pure function has_curves(self)
|
||||
class(square_t), intent(in) :: self
|
||||
logical :: has_curves
|
||||
|
||||
has_curves = .false.
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,68 @@
|
|||
module triangle_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, to_string, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: triangle_t
|
||||
|
||||
type, extends(shape_t) :: triangle_t
|
||||
private
|
||||
real :: base
|
||||
real :: height
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string => triangle_to_string
|
||||
procedure, public :: scale
|
||||
procedure, public :: area
|
||||
procedure, public :: has_curves
|
||||
end type
|
||||
|
||||
interface triangle_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(base, height) result(triangle)
|
||||
real, intent(in) :: base
|
||||
real, intent(in) :: height
|
||||
type(triangle_t) :: triangle
|
||||
|
||||
triangle%base = base
|
||||
triangle%height = height
|
||||
end function
|
||||
|
||||
pure function triangle_to_string(self) result(string)
|
||||
class(triangle_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"triangle_t(" // NEWLINE &
|
||||
// "base = " // to_string(self%base) // "," // NEWLINE &
|
||||
// "height = " // to_string(self%height), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
|
||||
function scale(self, factor) result(scaled)
|
||||
class(triangle_t), intent(in) :: self
|
||||
real, intent(in) :: factor
|
||||
class(shape_t), allocatable :: scaled
|
||||
|
||||
allocate(scaled, source = triangle_t(base = self%base * factor, height = self%height * factor))
|
||||
end function
|
||||
|
||||
pure function area(self)
|
||||
class(triangle_t), intent(in) :: self
|
||||
real :: area
|
||||
|
||||
area = (self%base * self%height) / 2.0
|
||||
end function
|
||||
|
||||
pure function has_curves(self)
|
||||
class(triangle_t), intent(in) :: self
|
||||
logical :: has_curves
|
||||
|
||||
has_curves = .false.
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,48 @@
|
|||
program main
|
||||
use circle_m, only: circle_t
|
||||
use filter_out_curves_m, only: filter_out_curves_t
|
||||
use iso_varying_string, only: put_line
|
||||
use shape_list_m, only: shape_list_t
|
||||
use shape_item_m, only: shape_item_t
|
||||
use square_m, only: square_t
|
||||
use strff, only: to_string
|
||||
use triangle_m, only: triangle_t
|
||||
|
||||
implicit none
|
||||
|
||||
type(shape_list_t) :: list
|
||||
type(shape_list_t) :: duplicated_list
|
||||
type(shape_list_t) :: filtered
|
||||
|
||||
list = shape_list_t( &
|
||||
shapes = [ &
|
||||
shape_item_t( &
|
||||
shape = square_t( &
|
||||
width = 2.0 &
|
||||
) &
|
||||
), &
|
||||
shape_item_t( &
|
||||
shape = circle_t( &
|
||||
radius = 3.0 &
|
||||
) &
|
||||
), &
|
||||
shape_item_t( &
|
||||
shape = triangle_t( &
|
||||
base = 4.0, &
|
||||
height = 5.0 &
|
||||
) &
|
||||
) &
|
||||
] &
|
||||
)
|
||||
|
||||
call put_line(list%to_string())
|
||||
call put_line(to_string(list%total_area()))
|
||||
|
||||
duplicated_list = (list*2.0) // (list*0.3)
|
||||
|
||||
call put_line(duplicated_list%to_string())
|
||||
|
||||
filtered = duplicated_list%filtered_by(filter_out_curves_t())
|
||||
|
||||
call put_line(filtered%to_string())
|
||||
end program
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
name = "heterogeneous_list"
|
||||
version = "0.1.0"
|
||||
license = "MIT"
|
||||
author = "Brad Richardson"
|
||||
maintainer = "everythingfunctional@protonmail.com"
|
||||
copyright = "2020 Brad Richardson"
|
||||
|
||||
[dependencies]
|
||||
iso_varying_string = { git = "https://gitlab.com/everythingfunctional/iso_varying_string.git", tag = "v2.0.0" }
|
||||
strff = { git = "https://gitlab.com/everythingfunctional/strff.git", tag = "v2.0.1" }
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
module circle_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, to_string, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: circle_t
|
||||
|
||||
type, extends(shape_t) :: circle_t
|
||||
private
|
||||
real :: radius
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string => circle_to_string
|
||||
procedure, public :: scale
|
||||
procedure, public :: area
|
||||
procedure, public :: has_curves
|
||||
end type
|
||||
|
||||
interface circle_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(radius) result(circle)
|
||||
real, intent(in) :: radius
|
||||
type(circle_t) :: circle
|
||||
|
||||
circle%radius = radius
|
||||
end function
|
||||
|
||||
pure function circle_to_string(self) result(string)
|
||||
class(circle_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"circle_t(" // NEWLINE &
|
||||
// "radius = " // to_string(self%radius), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
|
||||
function scale(self, factor) result(scaled)
|
||||
class(circle_t), intent(in) :: self
|
||||
real, intent(in) :: factor
|
||||
class(shape_t), allocatable :: scaled
|
||||
|
||||
allocate(scaled, source = circle_t(radius = self%radius * factor))
|
||||
end function
|
||||
|
||||
pure function area(self)
|
||||
class(circle_t), intent(in) :: self
|
||||
real :: area
|
||||
|
||||
area = 3.1415 * self%radius**2
|
||||
end function
|
||||
|
||||
pure function has_curves(self)
|
||||
class(circle_t), intent(in) :: self
|
||||
logical :: has_curves
|
||||
|
||||
has_curves = .true.
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
module filter_out_curves_m
|
||||
use shape_m, only: shape_t
|
||||
use shape_filterer_m, only: shape_filterer_t
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: filter_out_curves_t
|
||||
|
||||
type, extends(shape_filterer_t) :: filter_out_curves_t
|
||||
contains
|
||||
private
|
||||
procedure, public :: matches
|
||||
end type
|
||||
contains
|
||||
pure function matches(self, shape)
|
||||
class(filter_out_curves_t), intent(in) :: self
|
||||
class(shape_t), intent(in) :: shape
|
||||
logical :: matches
|
||||
|
||||
matches = .not. shape%has_curves()
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
module shape_filterer_m
|
||||
use shape_m, only: shape_t
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: shape_filterer_t
|
||||
|
||||
type, abstract :: shape_filterer_t
|
||||
contains
|
||||
private
|
||||
procedure(matches_i), deferred, public :: matches
|
||||
end type
|
||||
|
||||
abstract interface
|
||||
pure function matches_i(self, shape) result(matches)
|
||||
import :: shape_t, shape_filterer_t
|
||||
|
||||
implicit none
|
||||
|
||||
class(shape_filterer_t), intent(in) :: self
|
||||
class(shape_t), intent(in) :: shape
|
||||
logical :: matches
|
||||
end function
|
||||
end interface
|
||||
end module
|
||||
|
|
@ -0,0 +1,67 @@
|
|||
module shape_item_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use shape_filterer_m, only: shape_filterer_t
|
||||
use strff, only: hanging_indent, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: shape_item_t
|
||||
|
||||
type :: shape_item_t
|
||||
private
|
||||
class(shape_t), allocatable :: shape
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string
|
||||
procedure :: scale
|
||||
generic, public :: operator(*) => scale
|
||||
procedure, public :: area
|
||||
procedure, public :: satisfies
|
||||
end type
|
||||
|
||||
interface shape_item_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
function constructor(shape) result(shape_item)
|
||||
class(shape_t), intent(in) :: shape
|
||||
type(shape_item_t) :: shape_item
|
||||
|
||||
allocate(shape_item%shape, source = shape)
|
||||
end function
|
||||
|
||||
elemental function to_string(self) result(string)
|
||||
class(shape_item_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"shape_item_t(" // NEWLINE &
|
||||
// "shape = " // self%shape%to_string(), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
|
||||
impure elemental function scale(self, factor) result(scaled)
|
||||
class(shape_item_t), intent(in) :: self
|
||||
real, intent(in) :: factor
|
||||
type(shape_item_t) :: scaled
|
||||
|
||||
allocate(scaled%shape, source = self%shape * factor)
|
||||
end function
|
||||
|
||||
elemental function area(self)
|
||||
class(shape_item_t), intent(in) :: self
|
||||
real :: area
|
||||
|
||||
area = self%shape%area()
|
||||
end function
|
||||
|
||||
elemental function satisfies(self, filterer)
|
||||
class(shape_item_t), intent(in) :: self
|
||||
class(shape_filterer_t), intent(in) :: filterer
|
||||
logical :: satisfies
|
||||
|
||||
satisfies = filterer%matches(self%shape)
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,79 @@
|
|||
module shape_list_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_filterer_m, only: shape_filterer_t
|
||||
use shape_item_m, only: shape_item_t
|
||||
use strff, only: hanging_indent, indent, join, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: shape_list_t
|
||||
|
||||
type :: shape_list_t
|
||||
private
|
||||
type(shape_item_t), allocatable :: shapes(:)
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string
|
||||
procedure :: concat
|
||||
generic, public :: operator(//) => concat
|
||||
procedure :: scale
|
||||
generic, public :: operator(*) => scale
|
||||
procedure, public :: total_area
|
||||
procedure, public :: filtered_by
|
||||
end type
|
||||
|
||||
interface shape_list_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
function constructor(shapes) result(shape_list)
|
||||
type(shape_item_t), intent(in) :: shapes(:)
|
||||
type(shape_list_t) :: shape_list
|
||||
|
||||
allocate(shape_list%shapes, source = shapes)
|
||||
end function
|
||||
|
||||
pure function to_string(self) result(string)
|
||||
class(shape_list_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"shape_list_t(" // NEWLINE &
|
||||
// "shapes = [" // NEWLINE &
|
||||
// indent(join(self%shapes%to_string(), "," // NEWLINE), 4) // NEWLINE &
|
||||
// "]", &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
|
||||
function concat(lhs, rhs) result(combined)
|
||||
class(shape_list_t), intent(in) :: lhs
|
||||
type(shape_list_t), intent(in) :: rhs
|
||||
type(shape_list_t) :: combined
|
||||
|
||||
allocate(combined%shapes, source = [lhs%shapes, rhs%shapes])
|
||||
end function
|
||||
|
||||
function scale(self, factor) result(scaled)
|
||||
class(shape_list_t), intent(in) :: self
|
||||
real, intent(in) :: factor
|
||||
type(shape_list_t) :: scaled
|
||||
|
||||
allocate(scaled%shapes, source = self%shapes * factor)
|
||||
end function
|
||||
|
||||
pure function total_area(self)
|
||||
class(shape_list_t), intent(in) :: self
|
||||
real :: total_area
|
||||
|
||||
total_area = sum(self%shapes%area())
|
||||
end function
|
||||
|
||||
function filtered_by(self, filterer) result(filtered)
|
||||
class(shape_list_t), intent(in) :: self
|
||||
class(shape_filterer_t), intent(in) :: filterer
|
||||
type(shape_list_t) :: filtered
|
||||
|
||||
allocate(filtered%shapes, source = pack(self%shapes, mask = self%shapes%satisfies(filterer)))
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,56 @@
|
|||
module shape_m
|
||||
use iso_varying_string, only: varying_string
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: shape_t
|
||||
|
||||
type, abstract :: shape_t
|
||||
contains
|
||||
private
|
||||
procedure(to_string_i), deferred, public :: to_string
|
||||
procedure(scale_i), deferred, public :: scale
|
||||
generic, public :: operator(*) => scale
|
||||
procedure(area_i), deferred, public :: area
|
||||
procedure(has_curves_i), deferred, public :: has_curves
|
||||
end type
|
||||
|
||||
abstract interface
|
||||
pure function to_string_i(self) result(string)
|
||||
import :: shape_t, varying_string
|
||||
|
||||
implicit none
|
||||
|
||||
class(shape_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
end function
|
||||
|
||||
function scale_i(self, factor) result(scaled)
|
||||
import :: shape_t
|
||||
|
||||
implicit none
|
||||
|
||||
class(shape_t), intent(in) :: self
|
||||
real, intent(in) :: factor
|
||||
class(shape_t), allocatable :: scaled
|
||||
end function
|
||||
|
||||
pure function area_i(self) result(area)
|
||||
import :: shape_t
|
||||
|
||||
implicit none
|
||||
|
||||
class(shape_t), intent(in) :: self
|
||||
real :: area
|
||||
end function
|
||||
|
||||
pure function has_curves_i(self) result(has_curves)
|
||||
import :: shape_t
|
||||
|
||||
implicit none
|
||||
|
||||
class(shape_t), intent(in) :: self
|
||||
logical :: has_curves
|
||||
end function
|
||||
end interface
|
||||
end module
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
module square_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, to_string, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: square_t
|
||||
|
||||
type, extends(shape_t) :: square_t
|
||||
private
|
||||
real :: width
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string => square_to_string
|
||||
procedure, public :: scale
|
||||
procedure, public :: area
|
||||
procedure, public :: has_curves
|
||||
end type
|
||||
|
||||
interface square_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(width) result(square)
|
||||
real, intent(in) :: width
|
||||
type(square_t) :: square
|
||||
|
||||
square%width = width
|
||||
end function
|
||||
|
||||
pure function square_to_string(self) result(string)
|
||||
class(square_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"square_t(" // NEWLINE &
|
||||
// "width = " // to_string(self%width), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
|
||||
function scale(self, factor) result(scaled)
|
||||
class(square_t), intent(in) :: self
|
||||
real, intent(in) :: factor
|
||||
class(shape_t), allocatable :: scaled
|
||||
|
||||
allocate(scaled, source = square_t(width = self%width * factor))
|
||||
end function
|
||||
|
||||
pure function area(self)
|
||||
class(square_t), intent(in) :: self
|
||||
real :: area
|
||||
|
||||
area = self%width**2
|
||||
end function
|
||||
|
||||
pure function has_curves(self)
|
||||
class(square_t), intent(in) :: self
|
||||
logical :: has_curves
|
||||
|
||||
has_curves = .false.
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,68 @@
|
|||
module triangle_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, to_string, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: triangle_t
|
||||
|
||||
type, extends(shape_t) :: triangle_t
|
||||
private
|
||||
real :: base
|
||||
real :: height
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string => triangle_to_string
|
||||
procedure, public :: scale
|
||||
procedure, public :: area
|
||||
procedure, public :: has_curves
|
||||
end type
|
||||
|
||||
interface triangle_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(base, height) result(triangle)
|
||||
real, intent(in) :: base
|
||||
real, intent(in) :: height
|
||||
type(triangle_t) :: triangle
|
||||
|
||||
triangle%base = base
|
||||
triangle%height = height
|
||||
end function
|
||||
|
||||
pure function triangle_to_string(self) result(string)
|
||||
class(triangle_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"triangle_t(" // NEWLINE &
|
||||
// "base = " // to_string(self%base) // "," // NEWLINE &
|
||||
// "height = " // to_string(self%height), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
|
||||
function scale(self, factor) result(scaled)
|
||||
class(triangle_t), intent(in) :: self
|
||||
real, intent(in) :: factor
|
||||
class(shape_t), allocatable :: scaled
|
||||
|
||||
allocate(scaled, source = triangle_t(base = self%base * factor, height = self%height * factor))
|
||||
end function
|
||||
|
||||
pure function area(self)
|
||||
class(triangle_t), intent(in) :: self
|
||||
real :: area
|
||||
|
||||
area = (self%base * self%height) / 2.0
|
||||
end function
|
||||
|
||||
pure function has_curves(self)
|
||||
class(triangle_t), intent(in) :: self
|
||||
logical :: has_curves
|
||||
|
||||
has_curves = .false.
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
program main
|
||||
use circle_m, only: circle_t
|
||||
use iso_varying_string, only: put_line
|
||||
use shape_list_m, only: shape_list_t
|
||||
use shape_item_m, only: shape_item_t
|
||||
use square_m, only: square_t
|
||||
use triangle_m, only: triangle_t
|
||||
|
||||
implicit none
|
||||
|
||||
type(shape_list_t) :: list
|
||||
type(shape_list_t) :: duplicated_list
|
||||
|
||||
list = shape_list_t( &
|
||||
shapes = [ &
|
||||
shape_item_t( &
|
||||
shape = square_t( &
|
||||
width = 2.0 &
|
||||
) &
|
||||
), &
|
||||
shape_item_t( &
|
||||
shape = circle_t( &
|
||||
radius = 3.0 &
|
||||
) &
|
||||
), &
|
||||
shape_item_t( &
|
||||
shape = triangle_t( &
|
||||
base = 4.0, &
|
||||
height = 5.0 &
|
||||
) &
|
||||
) &
|
||||
] &
|
||||
)
|
||||
|
||||
call put_line(list%to_string())
|
||||
|
||||
duplicated_list = (list*2.0) // (list*0.3)
|
||||
|
||||
call put_line(duplicated_list%to_string())
|
||||
end program
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
name = "heterogeneous_list"
|
||||
version = "0.1.0"
|
||||
license = "MIT"
|
||||
author = "Brad Richardson"
|
||||
maintainer = "everythingfunctional@protonmail.com"
|
||||
copyright = "2020 Brad Richardson"
|
||||
|
||||
[dependencies]
|
||||
iso_varying_string = { git = "https://gitlab.com/everythingfunctional/iso_varying_string.git", tag = "v2.0.0" }
|
||||
strff = { git = "https://gitlab.com/everythingfunctional/strff.git", tag = "v2.0.1" }
|
||||
|
|
@ -0,0 +1,48 @@
|
|||
module circle_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, to_string, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: circle_t
|
||||
|
||||
type, extends(shape_t) :: circle_t
|
||||
private
|
||||
real :: radius
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string => circle_to_string
|
||||
procedure, public :: scale
|
||||
end type
|
||||
|
||||
interface circle_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(radius) result(circle)
|
||||
real, intent(in) :: radius
|
||||
type(circle_t) :: circle
|
||||
|
||||
circle%radius = radius
|
||||
end function
|
||||
|
||||
pure function circle_to_string(self) result(string)
|
||||
class(circle_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"circle_t(" // NEWLINE &
|
||||
// "radius = " // to_string(self%radius), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
|
||||
function scale(self, factor) result(scaled)
|
||||
class(circle_t), intent(in) :: self
|
||||
real, intent(in) :: factor
|
||||
class(shape_t), allocatable :: scaled
|
||||
|
||||
allocate(scaled, source = circle_t(radius = self%radius * factor))
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,49 @@
|
|||
module shape_item_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: shape_item_t
|
||||
|
||||
type :: shape_item_t
|
||||
private
|
||||
class(shape_t), allocatable :: shape
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string
|
||||
procedure :: scale
|
||||
generic, public :: operator(*) => scale
|
||||
end type
|
||||
|
||||
interface shape_item_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
function constructor(shape) result(shape_item)
|
||||
class(shape_t), intent(in) :: shape
|
||||
type(shape_item_t) :: shape_item
|
||||
|
||||
allocate(shape_item%shape, source = shape)
|
||||
end function
|
||||
|
||||
elemental function to_string(self) result(string)
|
||||
class(shape_item_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"shape_item_t(" // NEWLINE &
|
||||
// "shape = " // self%shape%to_string(), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
|
||||
impure elemental function scale(self, factor) result(scaled)
|
||||
class(shape_item_t), intent(in) :: self
|
||||
real, intent(in) :: factor
|
||||
type(shape_item_t) :: scaled
|
||||
|
||||
allocate(scaled%shape, source = self%shape * factor)
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,61 @@
|
|||
module shape_list_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_item_m, only: shape_item_t
|
||||
use strff, only: hanging_indent, indent, join, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: shape_list_t
|
||||
|
||||
type :: shape_list_t
|
||||
private
|
||||
type(shape_item_t), allocatable :: shapes(:)
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string
|
||||
procedure :: concat
|
||||
generic, public :: operator(//) => concat
|
||||
procedure :: scale
|
||||
generic, public :: operator(*) => scale
|
||||
end type
|
||||
|
||||
interface shape_list_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
function constructor(shapes) result(shape_list)
|
||||
type(shape_item_t), intent(in) :: shapes(:)
|
||||
type(shape_list_t) :: shape_list
|
||||
|
||||
allocate(shape_list%shapes, source = shapes)
|
||||
end function
|
||||
|
||||
pure function to_string(self) result(string)
|
||||
class(shape_list_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"shape_list_t(" // NEWLINE &
|
||||
// "shapes = [" // NEWLINE &
|
||||
// indent(join(self%shapes%to_string(), "," // NEWLINE), 4) // NEWLINE &
|
||||
// "]", &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
|
||||
function concat(lhs, rhs) result(combined)
|
||||
class(shape_list_t), intent(in) :: lhs
|
||||
type(shape_list_t), intent(in) :: rhs
|
||||
type(shape_list_t) :: combined
|
||||
|
||||
allocate(combined%shapes, source = [lhs%shapes, rhs%shapes])
|
||||
end function
|
||||
|
||||
function scale(self, factor) result(scaled)
|
||||
class(shape_list_t), intent(in) :: self
|
||||
real, intent(in) :: factor
|
||||
type(shape_list_t) :: scaled
|
||||
|
||||
allocate(scaled%shapes, source = self%shapes * factor)
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,36 @@
|
|||
module shape_m
|
||||
use iso_varying_string, only: varying_string
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: shape_t
|
||||
|
||||
type, abstract :: shape_t
|
||||
contains
|
||||
private
|
||||
procedure(to_string_i), deferred, public :: to_string
|
||||
procedure(scale_i), deferred, public :: scale
|
||||
generic, public :: operator(*) => scale
|
||||
end type
|
||||
|
||||
abstract interface
|
||||
pure function to_string_i(self) result(string)
|
||||
import :: shape_t, varying_string
|
||||
|
||||
implicit none
|
||||
|
||||
class(shape_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
end function
|
||||
|
||||
function scale_i(self, factor) result(scaled)
|
||||
import :: shape_t
|
||||
|
||||
implicit none
|
||||
|
||||
class(shape_t), intent(in) :: self
|
||||
real, intent(in) :: factor
|
||||
class(shape_t), allocatable :: scaled
|
||||
end function
|
||||
end interface
|
||||
end module
|
||||
|
|
@ -0,0 +1,48 @@
|
|||
module square_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, to_string, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: square_t
|
||||
|
||||
type, extends(shape_t) :: square_t
|
||||
private
|
||||
real :: width
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string => square_to_string
|
||||
procedure, public :: scale
|
||||
end type
|
||||
|
||||
interface square_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(width) result(square)
|
||||
real, intent(in) :: width
|
||||
type(square_t) :: square
|
||||
|
||||
square%width = width
|
||||
end function
|
||||
|
||||
pure function square_to_string(self) result(string)
|
||||
class(square_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"square_t(" // NEWLINE &
|
||||
// "width = " // to_string(self%width), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
|
||||
function scale(self, factor) result(scaled)
|
||||
class(square_t), intent(in) :: self
|
||||
real, intent(in) :: factor
|
||||
class(shape_t), allocatable :: scaled
|
||||
|
||||
allocate(scaled, source = square_t(width = self%width * factor))
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,52 @@
|
|||
module triangle_m
|
||||
use iso_varying_string, only: varying_string, operator(//)
|
||||
use shape_m, only: shape_t
|
||||
use strff, only: hanging_indent, to_string, NEWLINE
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: triangle_t
|
||||
|
||||
type, extends(shape_t) :: triangle_t
|
||||
private
|
||||
real :: base
|
||||
real :: height
|
||||
contains
|
||||
private
|
||||
procedure, public :: to_string => triangle_to_string
|
||||
procedure, public :: scale
|
||||
end type
|
||||
|
||||
interface triangle_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
contains
|
||||
pure function constructor(base, height) result(triangle)
|
||||
real, intent(in) :: base
|
||||
real, intent(in) :: height
|
||||
type(triangle_t) :: triangle
|
||||
|
||||
triangle%base = base
|
||||
triangle%height = height
|
||||
end function
|
||||
|
||||
pure function triangle_to_string(self) result(string)
|
||||
class(triangle_t), intent(in) :: self
|
||||
type(varying_string) :: string
|
||||
|
||||
string = hanging_indent( &
|
||||
"triangle_t(" // NEWLINE &
|
||||
// "base = " // to_string(self%base) // "," // NEWLINE &
|
||||
// "height = " // to_string(self%height), &
|
||||
4) // NEWLINE &
|
||||
// ")"
|
||||
end function
|
||||
|
||||
function scale(self, factor) result(scaled)
|
||||
class(triangle_t), intent(in) :: self
|
||||
real, intent(in) :: factor
|
||||
class(shape_t), allocatable :: scaled
|
||||
|
||||
allocate(scaled, source = triangle_t(base = self%base * factor, height = self%height * factor))
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
name = "stack_example"
|
||||
license = "MIT"
|
||||
author = "Brad Richardson"
|
||||
maintainer = "everythingfunctional@protonmail.com"
|
||||
copyright = "2021 Brad Richardson"
|
||||
|
||||
[dependencies]
|
||||
erloff = { git = "https://gitlab.com/everythingfunctional/erloff.git", tag = "v2.0.0" }
|
||||
|
||||
[dev-dependencies]
|
||||
vegetables = { git = "https://gitlab.com/everythingfunctional/vegetables", tag = "v7.0.2" }
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
module fallible_integer_m
|
||||
use erloff, only: error_list_t
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: fallible_integer_t
|
||||
|
||||
type :: fallible_integer_t
|
||||
private
|
||||
integer :: value__
|
||||
type(error_list_t) :: errors_
|
||||
contains
|
||||
private
|
||||
procedure, public :: failed
|
||||
procedure, public :: value_
|
||||
procedure, public :: errors
|
||||
end type
|
||||
|
||||
interface fallible_integer_t
|
||||
module procedure from_value
|
||||
module procedure from_errors
|
||||
end interface
|
||||
contains
|
||||
function from_value(value_) result(fallible_integer)
|
||||
integer, intent(in) :: value_
|
||||
type(fallible_integer_t) :: fallible_integer
|
||||
|
||||
fallible_integer%value__ = value_
|
||||
end function
|
||||
|
||||
function from_errors(errors) result(fallible_integer)
|
||||
type(error_list_t), intent(in) :: errors
|
||||
type(fallible_integer_t) :: fallible_integer
|
||||
|
||||
fallible_integer%errors_ = errors
|
||||
end function
|
||||
|
||||
function failed(self)
|
||||
class(fallible_integer_t), intent(in) :: self
|
||||
logical :: failed
|
||||
|
||||
failed = self%errors_%has_any()
|
||||
end function
|
||||
|
||||
function value_(self)
|
||||
class(fallible_integer_t), intent(in) :: self
|
||||
integer :: value_
|
||||
|
||||
value_ = self%value__
|
||||
end function
|
||||
|
||||
function errors(self)
|
||||
class(fallible_integer_t), intent(in) :: self
|
||||
type(error_list_t) :: errors
|
||||
|
||||
errors = self%errors_
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,151 @@
|
|||
module stack_m
|
||||
use erloff, only: error_list_t, fatal_t, module_t, procedure_t, NOT_FOUND
|
||||
use fallible_integer_m, only: fallible_integer_t
|
||||
|
||||
implicit none
|
||||
private
|
||||
public :: fallible_stack_t, stack_t
|
||||
|
||||
type :: stack_t
|
||||
private
|
||||
integer, allocatable :: items(:)
|
||||
contains
|
||||
private
|
||||
procedure, public :: empty
|
||||
procedure, public :: top
|
||||
procedure, public :: pop
|
||||
procedure, public :: push
|
||||
procedure, public :: depth
|
||||
end type
|
||||
|
||||
type :: fallible_stack_t
|
||||
private
|
||||
type(stack_t) :: stack_
|
||||
type(error_list_t) :: errors_
|
||||
contains
|
||||
private
|
||||
procedure, public :: failed
|
||||
procedure, public :: stack
|
||||
procedure, public :: errors
|
||||
end type
|
||||
|
||||
interface stack_t
|
||||
module procedure constructor
|
||||
end interface
|
||||
|
||||
interface fallible_stack_t
|
||||
module procedure from_stack
|
||||
module procedure from_errors
|
||||
end interface
|
||||
|
||||
character(len=*), parameter :: MODULE_NAME = "stack_m"
|
||||
contains
|
||||
function constructor() result(empty_stack)
|
||||
type(stack_t) :: empty_stack
|
||||
|
||||
allocate(empty_stack%items, source = [integer::])
|
||||
end function
|
||||
|
||||
function empty(self)
|
||||
class(stack_t), intent(in) :: self
|
||||
logical :: empty
|
||||
|
||||
empty = self%depth() == 0
|
||||
end function
|
||||
|
||||
function top(self)
|
||||
class(stack_t), intent(in) :: self
|
||||
type(fallible_integer_t) :: top
|
||||
|
||||
if (self%empty()) then
|
||||
top = fallible_integer_t(error_list_t(fatal_t( &
|
||||
NOT_FOUND, &
|
||||
module_t(MODULE_NAME), &
|
||||
procedure_t("top"), &
|
||||
"Asked for top of an empty stack.")))
|
||||
else
|
||||
top = fallible_integer_t(self%items(1))
|
||||
end if
|
||||
end function
|
||||
|
||||
function pop(self) result(popped)
|
||||
class(stack_t), intent(in) :: self
|
||||
type(fallible_stack_t) :: popped
|
||||
|
||||
if (self%empty()) then
|
||||
popped = fallible_stack_t(error_list_t(fatal_t( &
|
||||
module_t(MODULE_NAME), &
|
||||
procedure_t("pop"), &
|
||||
"Attempted to pop an empty stack.")))
|
||||
else
|
||||
if (self%depth() > 1) then
|
||||
block
|
||||
type(stack_t) :: new_stack
|
||||
|
||||
new_stack%items = self%items(2:)
|
||||
popped = fallible_stack_t(new_stack)
|
||||
end block
|
||||
else
|
||||
popped = fallible_stack_t(stack_t())
|
||||
end if
|
||||
end if
|
||||
end function
|
||||
|
||||
function push(self, top) result(pushed)
|
||||
class(stack_t), intent(in) :: self
|
||||
integer, intent(in) :: top
|
||||
type(stack_t) :: pushed
|
||||
|
||||
if (self%empty()) then
|
||||
allocate(pushed%items, source = [top])
|
||||
else
|
||||
allocate(pushed%items, source = [top, self%items])
|
||||
end if
|
||||
end function
|
||||
|
||||
function depth(self)
|
||||
class(stack_t), intent(in) :: self
|
||||
integer :: depth
|
||||
|
||||
if (allocated(self%items)) then
|
||||
depth = size(self%items)
|
||||
else
|
||||
depth = 0
|
||||
end if
|
||||
end function
|
||||
|
||||
function from_stack(stack) result(fallible_stack)
|
||||
type(stack_t), intent(in) :: stack
|
||||
type(fallible_stack_t) :: fallible_stack
|
||||
|
||||
fallible_stack%stack_ = stack
|
||||
end function
|
||||
|
||||
function from_errors(errors) result(fallible_stack)
|
||||
type(error_list_t), intent(in) :: errors
|
||||
type(fallible_stack_t) :: fallible_stack
|
||||
|
||||
fallible_stack%errors_ = errors
|
||||
end function
|
||||
|
||||
function failed(self)
|
||||
class(fallible_stack_t), intent(in) :: self
|
||||
logical :: failed
|
||||
|
||||
failed = self%errors_%has_any()
|
||||
end function
|
||||
|
||||
function stack(self)
|
||||
class(fallible_stack_t), intent(in) :: self
|
||||
type(stack_t) :: stack
|
||||
|
||||
stack = self%stack_
|
||||
end function
|
||||
|
||||
function errors(self)
|
||||
class(fallible_stack_t), intent(in) :: self
|
||||
type(error_list_t) :: errors
|
||||
|
||||
errors = self%errors_
|
||||
end function
|
||||
end module
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
! Generated by make_vegetable_driver. DO NOT EDIT
|
||||
program main
|
||||
implicit none
|
||||
|
||||
call run()
|
||||
contains
|
||||
subroutine run()
|
||||
use stack_test, only: &
|
||||
stack_new_stack => test_new_stack, &
|
||||
stack_non_empty_stack => test_non_empty_stack
|
||||
use vegetables, only: test_item_t, test_that, run_tests
|
||||
|
||||
type(test_item_t) :: tests
|
||||
type(test_item_t) :: individual_tests(2)
|
||||
|
||||
individual_tests(1) = stack_new_stack()
|
||||
individual_tests(2) = stack_non_empty_stack()
|
||||
tests = test_that(individual_tests)
|
||||
|
||||
call run_tests(tests)
|
||||
end subroutine
|
||||
end program
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue