Category:Action! Bitmap tools

From Rosetta Code
Revision as of 17:30, 22 November 2021 by rosettacode>Amarok (→‎LOADPPM5.ACT)
(diff) ← Older revision | Latest revision (diff) | Newer revision → (diff)

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"