71 lines
1.4 KiB
Forth
71 lines
1.4 KiB
Forth
module RCImagePrimitive
|
|
use RCImageBasic
|
|
|
|
implicit none
|
|
|
|
type point
|
|
integer :: x, y
|
|
end type point
|
|
|
|
private :: swapcoord
|
|
|
|
contains
|
|
|
|
subroutine swapcoord(p1, p2)
|
|
integer, intent(inout) :: p1, p2
|
|
integer :: t
|
|
|
|
t = p2
|
|
p2 = p1
|
|
p1 = t
|
|
end subroutine swapcoord
|
|
|
|
subroutine draw_line(img, from, to, color)
|
|
type(rgbimage), intent(inout) :: img
|
|
type(point), intent(in) :: from, to
|
|
type(rgb), intent(in) :: color
|
|
|
|
type(point) :: rfrom, rto
|
|
integer :: dx, dy, error, ystep, x, y
|
|
logical :: steep
|
|
|
|
rfrom = from
|
|
rto = to
|
|
steep = (abs(rto%y - rfrom%y) > abs(rto%x - rfrom%x))
|
|
if ( steep ) then
|
|
call swapcoord(rfrom%x, rfrom%y)
|
|
call swapcoord(rto%x, rto%y)
|
|
end if
|
|
if ( rfrom%x > rto%x ) then
|
|
call swapcoord(rfrom%x, rto%x)
|
|
call swapcoord(rfrom%y, rto%y)
|
|
end if
|
|
|
|
dx = rto%x - rfrom%x
|
|
dy = abs(rto%y - rfrom%y)
|
|
error = dx / 2
|
|
y = rfrom%y
|
|
|
|
if ( rfrom%y < rto%y ) then
|
|
ystep = 1
|
|
else
|
|
ystep = -1
|
|
end if
|
|
|
|
do x = rfrom%x, rto%x
|
|
if ( steep ) then
|
|
call put_pixel(img, y, x, color)
|
|
else
|
|
call put_pixel(img, x, y, color)
|
|
end if
|
|
error = error - dy
|
|
if ( error < 0 ) then
|
|
y = y + ystep
|
|
error = error + dx
|
|
end if
|
|
end do
|
|
|
|
end subroutine draw_line
|
|
|
|
end module RCImagePrimitive
|