module shape_module
  type shape_type
    integer, private :: x_ = 0
    integer, private :: y_ = 0

  contains
    procedure, pass(this) :: getx
    procedure, pass(this) :: gety
    procedure, pass(this) :: setx
    procedure, pass(this) :: sety
    procedure, pass(this) :: moveto
    procedure, pass(this) :: draw
  end type shape_type
  interface shape_type
    module procedure shape_type_constructor
  end interface
  interface assignment (=)
    module procedure generic_shape_assign
  end interface

contains
  type (shape_type) function shape_type_constructor(x,y)
    implicit none
    integer, intent (in) :: x
    integer, intent (in) :: y

    shape_type_constructor%x_ = x
    shape_type_constructor%y_ = y
  end function shape_type_constructor
  integer function getx(this)
    implicit none

    class (shape_type), intent (in) :: this
    getx = this%x_
  end function getx
  integer function gety(this)
    implicit none

    class (shape_type), intent (in) :: this
    gety = this%y_
  end function gety
  subroutine setx(this,x)
    implicit none

    class (shape_type), intent (inout) :: this
    integer, intent (in) :: x
    this%x_ = x
  end subroutine setx
  subroutine sety(this,y)
    implicit none

    class (shape_type), intent (inout) :: this
    integer, intent (in) :: y
    this%y_ = y
  end subroutine sety
  subroutine moveto(this,newx,newy)
    implicit none

    class (shape_type), intent (inout) :: this
    integer, intent (in) :: newx
    integer, intent (in) :: newy
    this%x_ = newx
    this%y_ = newy
  end subroutine moveto
  subroutine draw(this)
    implicit none

    class (shape_type), intent (in) :: this
    print *, ' x = ', this%x_
    print *, ' y = ', this%y_
  end subroutine draw
  subroutine generic_shape_assign(lhs,rhs)
    implicit none

    class (shape_type), intent (out), allocatable :: lhs
    class (shape_type), intent (in) :: rhs
    allocate (lhs,source=rhs)
  end subroutine generic_shape_assign
end module shape_module

module circle_module
  use shape_module
  type, extends(shape_type) :: circle_type
    integer, private :: radius_

  contains
    procedure, pass(this) :: getradius
    procedure, pass(this) :: setradius
    procedure, pass(this) :: draw => draw_circle
  end type circle_type
  interface circle_type
    module procedure circle_type_constructor
  end interface

contains
  type (circle_type) function circle_type_constructor(x,y,radius)
    implicit none
    integer, intent (in) :: x
    integer, intent (in) :: y
    integer, intent (in) :: radius

    call circle_type_constructor%setx(x)
    call circle_type_constructor%sety(y)
    circle_type_constructor%radius_ = radius
  end function circle_type_constructor

  integer function getradius(this)
    implicit none

    class (circle_type), intent (in) :: this
    getradius = this%radius_
  end function getradius

  subroutine setradius(this,radius)
    implicit none

    class (circle_type), intent (inout) :: this
    integer, intent (in) :: radius
    this%radius_ = radius
  end subroutine setradius

  subroutine draw_circle(this)
    implicit none

    class (circle_type), intent (in) :: this
    print *, ' x = ', this%getx()
    print *, ' y = ', this%gety()
    print *, ' radius = ', this%radius_
  end subroutine draw_circle
end module circle_module

module rectangle_module
  use shape_module
  type, extends(shape_type) :: rectangle_type
    integer, private :: width_
    integer, private :: height_

  contains
    procedure, pass(this) :: getwidth
    procedure, pass(this) :: setwidth
    procedure, pass(this) :: getheight
    procedure, pass(this) :: setheight
    procedure, pass(this) :: draw => draw_rectangle
  end type rectangle_type
  interface rectangle_type
    module procedure rectangle_type_constructor
  end interface

contains
  type (rectangle_type) function rectangle_type_constructor(x,y,width,height)
    implicit none
    integer, intent (in) :: x
    integer, intent (in) :: y
    integer, intent (in) :: width
    integer, intent (in) :: height

    call rectangle_type_constructor%setx(x)
    call rectangle_type_constructor%sety(y)
    rectangle_type_constructor%width_ = width
    rectangle_type_constructor%height_ = height
  end function rectangle_type_constructor

  integer function getwidth(this)
    implicit none

    class (rectangle_type), intent (in) :: this
    getwidth = this%width_
  end function getwidth

  subroutine setwidth(this,width)
    implicit none

    class (rectangle_type), intent (inout) :: this
    integer, intent (in) :: width
    this%width_ = width
  end subroutine setwidth

  integer function getheight(this)
    implicit none

    class (rectangle_type), intent (in) :: this
    getheight = this%height_
  end function getheight

  subroutine setheight(this,height)
    implicit none

    class (rectangle_type), intent (inout) :: this
    integer, intent (in) :: height
    this%height_ = height
  end subroutine setheight

  subroutine draw_rectangle(this)
    implicit none

    class (rectangle_type), intent (in) :: this
    print *, ' x = ', this%getx()
    print *, ' y = ', this%gety()
    print *, ' width = ', this%width_
    print *, ' height = ', this%height_
  end subroutine draw_rectangle
end module rectangle_module

module shape_wrapper_module
  use shape_module
  use circle_module
  use rectangle_module
  type shape_wrapper

    class (shape_type), allocatable :: x
  end type shape_wrapper
end module shape_wrapper_module


module display_module

contains
  subroutine display(n_shapes,shape_array)
    use shape_wrapper_module
    implicit none
    integer, intent (in) :: n_shapes
    type (shape_wrapper), dimension (n_shapes) :: shape_array
    integer :: i

    do i = 1, n_shapes
      call shape_array(i) %x%draw()
    end do
  end subroutine display
end module display_module

program ch2605
  use shape_module
  use circle_module
  use rectangle_module
  use shape_wrapper_module
  use display_module
  implicit none
  integer, parameter :: n = 6
  integer :: i
  type (shape_wrapper), dimension (n) :: s

  s(1) %x = shape_type(10,20)
  s(2) %x = circle_type(100,200,300)
  s(3) %x = rectangle_type(1000,2000,3000,4000)
  s(4) %x = s(1) %x
  s(5) %x = s(2) %x
  s(6) %x = s(3) %x
  print *, ' calling display subroutine'
  call display(n,s)
  print *, ' select type with get methods'
  do i = 1, n
    select type(t=>s(i)%x)
    class is (shape_type)
    print *, ' x = ', t%getx(), ' y = ',t%gety()
    class is (circle_type)
    print *, ' x = ', t%getx(), ' y = ',t%gety()
    print *, ' radius = ', t%getradius()
    class is (rectangle_type)
    print *, ' x = ', t%getx(), ' y = ',t%gety()
    print *, ' height = ', t%getheight()
    print *, ' width = ', t%getwidth()
    class default
    print *, ' do nothing'
  end select
end do
print *, ' select type with set methods'
do i = 1, n
  select type(t=>s(i)%x)
  class is (shape_type)
  call t%setx(19)
  call t%sety(19)
  class is (circle_type)
  call t%setx(199)
  call t%sety(199)
  call t%setradius(199)
  class is (rectangle_type)
  call t%setx(1999)
  call t%sety(1999)
  call t%setheight(1999)
  call t%setwidth(1999)
  class default
  print *, ' do nothing'
end select
end do
print *, ' calling display subroutine'
call display(n,s)
end program ch2605