Jump to content

Category:Action! Bitmap tools

From Rosetta Code

Action! Bitmap tools

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

GRIMAGE.ACT

The following module contains definition of grayscale image. <lang Action!>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</lang>

RGBIMAGE.ACT

The following module contains definition of RGB color image. <lang Action!>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</lang>

RGBLINE.ACT

The following module contains implementation of Bresenham's algorithm for drawing line on RGB color image. <lang Action!>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</lang>

RGBCIRCL.ACT

The following module contains implementation of drawing circle on RGB color image using midpoint circle algorithm. <lang Action!>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</lang>

RGB2GRAY.ACT

The following module is responsible for conversion from RGB color image into grayscale image. <lang Action!>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</lang>

LOADPPM5.ACT

The following module is designed for loading images in PPM format version 5 (grayscale, binary). <lang Action!>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</lang>

Retrieved from "https://rosettacode.org/wiki/Category:Action!_Bitmap_tools?oldid=317487"
Cookies help us deliver our services. By using our services, you agree to our use of cookies.
More information