I'm working on modernizing Rosetta Code's infrastructure. Starting with communications. Please accept this time-limited open invite to RC's Slack.. --Michael Mol (talk) 20:59, 30 May 2020 (UTC)

Category:Action! Bitmap tools

From Rosetta Code

Action! Bitmap tools[edit]

All the following source codes have been prepared to solve tasks in the Rosetta Code website.


GRIMAGE.ACT[edit]

The following module contains definition of grayscale image.

MODULE
 
TYPE GrayImage=[
BYTE gw,gh
CARD gdata]
 
PROC InitGrayImage(GrayImage POINTER img
BYTE width,height CARD d)
 
img.gw=width
img.gh=height
img.gdata=d
RETURN
 
PROC FillGrayImage(GrayImage POINTER img BYTE c)
SetBlock(img.gdata,img.gw*img.gh,c)
RETURN
 
CARD FUNC GetGrayPtr(GrayImage POINTER img INT x,y)
IF x<0 OR x>=img.gw OR y<0 OR y>=img.gh THEN
RETURN (0)
FI
RETURN (img.gdata+x+y*img.gw)
 
BYTE FUNC GetGrayPixel(GrayImage POINTER img
INT x,y)
BYTE POINTER ptr
 
ptr=GetGrayPtr(img,x,y)
IF ptr=0 THEN
Break()
FI
RETURN (ptr^)
 
PROC SetGrayPixel(GrayImage POINTER img
INT x,y BYTE c)
BYTE POINTER ptr
 
ptr=GetGrayPtr(img,x,y)
IF ptr THEN
ptr^=c
FI
RETURN
 
MODULE

RGBIMAGE.ACT[edit]

The following module contains definition of RGB color image.

MODULE
 
DEFINE RGBSIZE="3"
 
TYPE RGB=[BYTE r,g,b]
 
TYPE RgbImage=[
BYTE w,h
CARD data]
 
BYTE FUNC RgbEqual(RGB POINTER c1,c2)
IF c1.r=c2.r AND c1.g=c2.g AND c1.b=c2.b THEN
RETURN (1)
FI
RETURN (0)
 
PROC RgbBlack(RGB POINTER c)
c.r=0 c.g=0 c.b=0
RETURN
 
PROC RgbWhite(RGB POINTER c)
c.r=255 c.g=255 c.b=255
RETURN
 
PROC RgbRed(RGB POINTER c)
c.r=255 c.g=0 c.b=0
RETURN
 
PROC RgbGreen(RGB POINTER c)
c.r=0 c.g=255 c.b=0
RETURN
 
PROC RgbBlue(RGB POINTER c)
c.r=0 c.g=0 c.b=255
RETURN
 
PROC RgbYellow(RGB POINTER c)
c.r=255 c.g=255 c.b=0
RETURN
 
PROC RgbViolet(RGB POINTER c)
c.r=255 c.g=0 c.b=255
RETURN
 
PROC InitRgbImage(RgbImage POINTER img
BYTE width,height CARD d)
 
img.w=width
img.h=height
img.data=d
RETURN
 
PROC FillRgbImage(RgbImage POINTER img RGB POINTER c)
RGB POINTER ptr
BYTE x,y
 
ptr=img.data
FOR y=1 TO img.h
DO
FOR x=1 TO img.w
DO
ptr.r=c.r
ptr.g=c.g
ptr.b=c.b
ptr==+3
OD
OD
RETURN
 
CARD FUNC GetRgbPtr(RgbImage POINTER img INT x,y)
IF x<0 OR x>=img.w OR y<0 OR y>=img.h THEN
RETURN (0)
FI
RETURN (img.data+(x+y*img.w)*RGBSIZE)
 
PROC GetRgbPixel(RgbImage POINTER img
INT x,y RGB POINTER c)
RGB POINTER ptr
 
ptr=GetRgbPtr(img,x,y)
IF ptr THEN
c.r=ptr.r
c.g=ptr.g
c.b=ptr.b
ELSE
Break()
FI
RETURN
 
PROC SetRgbPixel(RgbImage POINTER img
INT x,y RGB POINTER c)
RGB POINTER ptr
 
ptr=GetRgbPtr(img,x,y)
IF ptr THEN
ptr.r=c.r
ptr.g=c.g
ptr.b=c.b
FI
RETURN
 
MODULE

RGBLINE.ACT[edit]

The following module contains implementation of Bresenham's algorithm for drawing line on RGB color image.

MODULE
 
INCLUDE "H6:RGBIMAGE.ACT" ;from task Bitmap
 
PROC RgbLine(RgbImage POINTER img
INT x1,y1,x2,y2 RGB POINTER c)
INT dx,dy,sx,sy,err,e2
 
IF x1>x2 THEN dx=x1-x2
ELSE dx=x2-x1 FI
 
IF y1>y2 THEN dy=y1-y2
ELSE dy=y2-y1 FI
 
IF x1<x2 THEN sx=1
ELSE sx=-1 FI
 
IF y1<y2 THEN sy=1
ELSE sy=-1 FI
 
IF dx>dy THEN err=dx/2
ELSE err=-dy/2 FI
 
DO
SetRgbPixel(img,x1,y1,c)
IF x1=x2 AND y1=y2 THEN
EXIT
FI
e2=err
IF e2>-dx THEN
err==-dy
x1==+sx
FI
IF e2<dy THEN
err==+dx
y1==+sy
FI
OD
RETURN
 
MODULE

RGBCIRCL.ACT[edit]

The following module contains implementation of drawing circle on RGB color image using midpoint circle algorithm.

MODULE
 
INCLUDE "H6:RGBIMAGE.ACT" ;from task Bitmap
 
PROC RgbCircle(RgbImage POINTER img
INT x0,y0,radius RGB POINTER c)
INT f,ddfx,ddfy,x,y
 
f=1-radius
ddfx=0 ddfy=-2*radius
x=0 y=radius
 
SetRgbPixel(img,x0,y0+radius,c)
SetRgbPixel(img,x0,y0-radius,c)
SetRgbPixel(img,x0+radius,y0,c)
SetRgbPixel(img,x0-radius,y0,c)
 
WHILE x<y
DO
IF f>=0 THEN
y==-1
ddfy==+2
f==+ddfy
FI
x==+1
ddfx==+2
f==+ddfx+1
SetRgbPixel(img,x0+x,y0+y,c)
SetRgbPixel(img,x0-x,y0+y,c)
SetRgbPixel(img,x0+x,y0-y,c)
SetRgbPixel(img,x0-x,y0-y,c)
SetRgbPixel(img,x0+y,y0+x,c)
SetRgbPixel(img,x0-y,y0+x,c)
SetRgbPixel(img,x0+y,y0-x,c)
SetRgbPixel(img,x0-y,y0-x,c)
OD
RETURN
 
MODULE

RGB2GRAY.ACT[edit]

The following module is responsible for conversion from RGB color image into grayscale image.

MODULE
 
INCLUDE "H6:RGBIMAGE.ACT" ;from task Bitmap
INCLUDE "H6:GRIMAGE.ACT" ;from task Grayscale image
INCLUDE "D2:REAL.ACT" ;from the Action! Tool Kit
 
REAL rFact,gFact,bFact
 
PROC InitRgbToGray()
ValR("0.2126",rFact)
ValR("0.7152",gFact)
ValR("0.0722",bFact)
RETURN
 
BYTE FUNC Luminance(RGB POINTER c)
REAL r1,r2,r3
 
IntToReal(c.r,r1)  ;r1=R
RealMult(rFact,r1,r2) ;r2=0.2126*R
IntToReal(c.g,r1)  ;r1=G
RealMult(gFact,r1,r3) ;r3=0.7152*G
RealAdd(r2,r3,r1)  ;r1=0.2126*R+0.7152*G
IntToReal(c.b,r2)  ;r2=B
RealMult(bFact,r2,r3) ;r3=0.0722*B
RealAdd(r1,r3,r2)  ;r2=0.2126*R+0.7152*G+0.0722*B
RETURN (RealToInt(r2))
 
PROC RgbToGray(RgbImage POINTER src GrayImage POINTER dst)
BYTE x,y,lum
RGB c
 
FOR y=0 TO dst.h-1
DO
FOR x=0 TO dst.w-1
DO
GetRgbPixel(src,x,y,c)
lum=Luminance(c)
SetGrayPixel(dst,x,y,lum)
OD
OD
RETURN
 
PROC GrayToRgb(GrayImage POINTER src RgbImage POINTER dst)
BYTE x,y,lum
RGB c
 
FOR y=0 TO dst.h-1
DO
FOR x=0 TO dst.w-1
DO
lum=GetGrayPixel(src,x,y)
c.r=lum c.g=lum c.b=lum
SetRgbPixel(dst,x,y,c)
OD
OD
RETURN
 
MODULE

LOADPPM5.ACT[edit]

The following module is designed for loading images in PPM format version 5 (grayscale, binary).

MODULE
 
INCLUDE "H6:GRIMAGE.ACT" ;from task Grayscale image
 
PROC DecodeSize(CHAR ARRAY s BYTE POINTER width,height)
BYTE i
 
width^=ValB(s)
i=1
WHILE i<=s(0) AND s(i)#32
DO
s(i)=32
i==+1
OD
height^=ValB(s)
RETURN
 
PROC LoadHeader(GrayImage POINTER img
CHAR ARRAY format BYTE dev)
CHAR ARRAY line(255)
BYTE header,size,max,width,height
 
header=0 size=0 max=0
WHILE max=0
DO
InputSD(dev,line)
IF line(0)>0 AND line(1)#'# THEN
IF header=0 THEN
IF SCompare(format,format)#0 THEN
Break()
FI
header=1
ELSEIF size=0 THEN
DecodeSize(line,@width,@height)
IF width=0 OR height=0 THEN
Break()
FI
img.gw=width img.gh=height
size=1
ELSEIF max=0 THEN
max=ValB(line)
IF max#255 THEN
Break()
FI
FI
FI
OD
RETURN
 
PROC LoadPPM5(GrayImage POINTER img CHAR ARRAY path)
BYTE dev=[1],x,y,c
 
Close(dev)
Open(dev,path,4)
LoadHeader(img,"P5",dev)
FOR y=0 TO img.gh-1
DO
FOR x=0 TO img.gw-1
DO
c=GetD(dev)
SetGrayPixel(img,x,y,c)
OD
OD
Close(dev)
RETURN
 
MODULE