Image resizing

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
ITomi
Posts: 189
Joined: Jul 31, 2015 11:23
Location: Hungary

Image resizing

Post by ITomi »

Hello!

As I know, basically there is no built in command to resize images in FB, although users implement this with own codes.
I made one too, but it's not perfect for some reason, because as if it would rotate the image.
I don't want reinvent the wheel, but I'm curious about the cause of the error and do you think this is a useful code?

Code: Select all

#if __FB_LANG__ = "qb"
#define EXTCHAR Chr$(0)
#else
#define EXTCHAR Chr(255)
#endif

#include "fbgfx.bi"
Using FB

dim shared as any ptr src_img,dest_img
dim shared as ubyte di_size=1 'Size of destination image

screenres 640,480,32

sub resize_img()
    dim as long result,w,h
    dim as integer xp,yp
    
    ImageDestroy dest_img
    
    result = imageinfo(src_img, w, h)
    dest_img=ImageCreate(w*di_size,h*di_size)
    
    xp=0
    yp=0
    
    for i as integer=0 to w-1 'Width
        for j as integer=0 to h-1 'Height
            for x as integer=xp to xp+di_size
                for y as integer=yp to yp+di_size
                    PSet dest_img,(x,y),Point(i,j,src_img)
                next y
            next x
            if xp+di_size<=w*di_size then
                xp+=di_size
            else
                xp=0 : yp+=di_size
            end if
        next j
    next i
end sub

'Creating a 32*32 size smiley as source image:
src_img = ImageCreate( 32, 32, RGB(255, 0, 255) )
Circle src_img, (16, 16), 15, RGB(255, 255, 0),     ,     , 1, f
Circle src_img, (10, 10), 3,  RGB(  0,   0, 0),     ,     , 2, f
Circle src_img, (23, 10), 3,  RGB(  0,   0, 0),     ,     , 2, f
Circle src_img, (16, 18), 10, RGB(  0,   0, 0), 3.14, 6.28

resize_img()

Do
    var k = Inkey$
    Select Case k
        Case EXTCHAR & "H" 'Up arrow
             if di_size<10 then
                 di_size+=1
                 resize_img()
             end if
        Case EXTCHAR & "P" 'Down arrow
             if di_size>1 then
                 di_size-=1
                 resize_img()
             end if
    end select
    screenlock
    cls
    Put (16, 32), src_img, Trans
    Put (320, 240), dest_img, Trans
    draw string (1,1),"Use UP and DOWN arrow keys to resize image; ESC to exit."
    draw string (1,12),"Size of the destination image: "+str(di_size)
    screenunlock
loop until multikey(sc_escape)

ImageDestroy src_img
ImageDestroy dest_img
fxm
Moderator
Posts: 12577
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: Image resizing

Post by fxm »

Add a small sleep at the end of the loop to improve responsiveness (to avoid to hug the cpu).
For example:

Code: Select all

    .....
    .....
    draw string (1,12),"Size of the destination image: "+str(di_size)
    screenunlock
    sleep 10
loop until multikey(sc_escape)
SARG
Posts: 1888
Joined: May 27, 2005 7:15
Location: FRANCE

Re: Image resizing

Post by SARG »

- commented lines where xp,yp are changed
- new assignmenst for xp/yp
- added pointval as the value is not modified in for x/ for Y loops

Code: Select all

sub resize_img()
    dim as long result,w,h,pointval
    dim as integer xp,yp
    
    ImageDestroy dest_img
    
    result = imageinfo(src_img, w, h)
    dest_img=ImageCreate(w*di_size,h*di_size)
    
    xp=0
    yp=0
    
    for i as integer=0 to w-1 'Width
        xp=i*di_size
        for j as integer=0 to h-1 'Height
        	pointval=Point(i,j,src_img)
            for x as integer=xp to xp+di_size
                for y as integer=yp to yp+di_size
                    PSet dest_img,(x,y),pointval
                next y
            next x
            'if xp+di_size<=w*di_size then
                'xp+=di_size
            'else
                'xp=0 : yp+=di_size
            'end if
            yp+=di_size
        next j
	yp=0
    next i
end sub
ITomi
Posts: 189
Joined: Jul 31, 2015 11:23
Location: Hungary

Re: Image resizing

Post by ITomi »

Great! It works! :D
Thanks for your advice and helpful addition, Fxm and SARG!
Now I just tried it, but I'm go to understand the changes in it...
fxm
Moderator
Posts: 12577
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: Image resizing

Post by fxm »

Why not only use the graphical instruction pair:
'View' / 'Window Screen'
and just draw the image at the right size in the clipping area.
This way we can use a non-integer zoom factor!

Code: Select all

#include "fbgfx.bi"
Using FB

Dim As Double zoom = 1 '' zoom factor of destination image

Screenres 640, 480, 32

Sub DrawImage() '' drawing 32*32
    Circle (16, 16), 15, RGB(255, 255, 0),     ,     , 1, f
    Circle (10, 10), 3,  RGB(  0,   0, 0),     ,     , 2, f
    Circle (22, 10), 3,  RGB(  0,   0, 0),     ,     , 2, f
    Circle (16, 18), 10, RGB(  0,   0, 0), 3.14, 6.28
End Sub


Do
    Var k = Inkey
    Select Case k
        Case Chr(255) & "H" 'Up arrow
            If zoom < 14 Then
                zoom += 0.25
            End If
        Case Chr(255) & "P" 'Down arrow
            If zoom > 1 Then
                zoom -= 0.25
            End If
    End Select
    Screenlock
    Cls
    View(0, 24)-(0 + 32 * zoom - 1, 24 + 32 * zoom - 1)
    Window Screen(0, 0)-(32, 32)
    DrawImage()
    View
    Window
    Draw String (1, 1),"Use 'UP' and 'DOWN' arrow keys to resize image; 'ESC' to exit."
    Draw String (1, 12),"Zoom factor of the destination image: " & Str(zoom)
    Screenunlock
    Sleep 10
Loop Until Multikey(sc_escape)

Sleep
badidea
Posts: 2636
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Image resizing

Post by badidea »

With MultiPut @ https://www.freebasic.net/forum/viewtopic.php?t=24479
And code:

Code: Select all

#if __FB_LANG__ = "qb"
#define EXTCHAR Chr$(0)
#else
#define EXTCHAR Chr(255)
#endif

#include "fbgfx.bi"
Using FB

dim shared as any ptr src_img
dim shared as single di_size=1.0 'Size of destination image

screenres 640,480,32

'Creating a 32*32 size smiley as source image:
src_img = ImageCreate( 32, 32, RGB(255, 0, 255) )
Circle src_img, (16, 16), 15, RGB(255, 255, 0),     ,     , 1, f
Circle src_img, (10, 10), 3,  RGB(  0,   0, 0),     ,     , 2, f
Circle src_img, (23, 10), 3,  RGB(  0,   0, 0),     ,     , 2, f
Circle src_img, (16, 18), 10, RGB(  0,   0, 0), 3.14, 6.28

Do
	var k = Inkey$
	Select Case k
		Case EXTCHAR & "H" 'Up arrow
			 if di_size<10 then
				 di_size+=0.1
			 end if
		Case EXTCHAR & "P" 'Down arrow
			 if di_size>0.2 then
				 di_size-=0.1
			 end if
	end select
	screenlock
	cls
	Put (16, 32), src_img, Trans
	MultiPut(0, 320, 240, src_img, di_size, di_size, 0, false)

	draw string (1,1),"Use UP and DOWN arrow keys to resize image; ESC to exit."
	draw string (1,12),"Size of the destination image: "+str(di_size)
	screenunlock
	sleep 10
loop until multikey(sc_escape)

ImageDestroy src_img
ITomi
Posts: 189
Joined: Jul 31, 2015 11:23
Location: Hungary

Re: Image resizing

Post by ITomi »

Wow, it's getting better! :o I didn't know these methods, but seems good. These are much simpler than my solution. And maybe faster, too.
dodicat
Posts: 8267
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Image resizing

Post by dodicat »

An axe instead of smiler.

Code: Select all



Sub rotateimage(Byref dest As Any Ptr=0,im As Any Ptr,angle As Single,shiftx As Long=0,shifty As Long=0,sc As Single=1,miss As Ulong=Rgb(255,0,255),fixedpivot As boolean=false)
    Static As Integer pitch,pitchs,xres,yres,runflag
    Static As Any Ptr row,rows
    Static As Integer ddx,ddy,resultx,resulty
    Imageinfo im,ddx,ddy,,pitch,row
    If dest=0 Then
    Screeninfo xres,yres,,,pitchS
    rowS=Screenptr
    Else
    If sc<>1 Then 
        Dim As Integer x,y
        Imageinfo dest,x,y
    Imagedestroy dest:dest=0: dest=Imagecreate(x*sc,y*sc)
    End If
    Imageinfo dest, xres,yres,,pitchS,rows
    End If
    Dim As Long centreX=ddx\2,centreY=ddy\2
    Dim As Single sx=Sin(angle)
    Dim As Single cx=Cos(angle)
    Dim As Long mx=Iif(ddx>=ddy,ddx,ddy),shftx,shfty
    Var fx=sc*.7071067811865476,sc2=1/sc
    If fixedpivot=false Then
     shiftx+=centreX*sc-centrex
     shiftY+=centrey*sc-centrey
     End If
    For y As Long=centrey-fx*mx+1 To centrey+ fx*mx 
        Dim As Single sxcy=Sx*(y-centrey),cxcy=Cx*(y-centrey)
        shfty=y+shifty
        For x As Long=centrex-mx*fx To centrex+mx*fx 
                 If x+shiftx >=0 Then 'on the screen
                    If x+shiftx <xres Then
                        If shfty >=0 Then
                            If shfty<yres Then
            resultx=sc2*(Cx*(x-centrex)-Sxcy) +centrex:resulty=sc2*(Sx*(x-centrex)+Cxcy) +centrey
                If resultx >=0 Then 'on the image
                    If resultx<ddx Then
                        If resulty>=0 Then
                            If resulty<ddy Then
    Dim As Ulong u=*Cast(Ulong Ptr,row+pitch*((resultY))+((resultX)) Shl 2 ) 'point(image)
   If u<>miss Then *Cast(Ulong Ptr,rowS+pitchS*(y+shifty)+(x+shiftx) Shl 2)= u 'pset (screen)
                End If:End If:End If:End If
                End If:End If:End If:End If
        Next x
    Next y
End Sub

Function Regulate(Byval MyFps As Long,Byref fps As Long=0) As Long
    Static As Double timervalue,_lastsleeptime,t3,frames
    Var t=Timer
    frames+=1
    If (t-t3)>=1 Then t3=t:fps=frames:frames=0
    Var sleeptime=_lastsleeptime+((1/myfps)-T+timervalue)*1000
    If sleeptime<1 Then sleeptime=1
    _lastsleeptime=sleeptime
    timervalue=T
    Return sleeptime
End Function



Screenres 1060,762,32

Var i=Imagecreate(200,200),i2=Imagecreate(1060,762,rgb(0,100,0))
#define range(f,l) Rnd*((l)-(f))+(f)
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
For n As Long=0 To 762-200  'background to i2
        Var red=map(0,762,n,0,255)
        Var green=map(0,762,n,0,255)
        Var blue=map(0,762,n,220,255)
        Line i2,(0,n)-(1060,n),Rgb(red,green,blue)
    Next
    'axe to i
Var col=Rgb(110,53,0),s=Rgb(140,140,140)
Circle i,(169,150-15),25+12,s,4.1,5.3
Line i,(160,75)-(165,75),s
Line i,(160,75)-(149,165),s
Line i,(165,75)-(189,165),s
Line i,(149,165)-(189,165),s
Paint i,(170,150),s,s
Paint i,(162,80),s,s
Paint i,(180,167),s,s
For x As Long=30 To 80 Step 10
    Circle i,(x,100),7,Rgb(100,40,0),,,,f
    Next
Line i,(10,95)-(190,105),col,bf

Do
Var f=range(.2,2)
Dim As Double n
dim as long fps
Do
    n+=f/10
    Screenlock
    Put(0,0),i2,Pset
  Put(0,-70),i,trans 
  Draw String(200,20),"ORIGINAL"
  Draw String(400,20),"Magnifacation  " & f
  Draw String(800,20),"Framerate " & fps
rotateimage(,i,-n,50*n-100,300,f,,true) '<--- scaled/rotated image here
Screenunlock
Sleep regulate(60,fps)
If Len(Inkey) Then Exit Do,Do
Loop Until 50*n>900
Sleep 500
Cls
Loop Until Len(Inkey)
imagedestroy i
imagedestroy i2
 
ITomi
Posts: 189
Joined: Jul 31, 2015 11:23
Location: Hungary

Re: Image resizing

Post by ITomi »

Hi, Dodicat!

I tried to run your code, but FB gave me 3 error messages:
1. error 58: Illegal specification, at parameter 8 (fixedpivot) of rotateimage() in 'Sub rotateimage(Byref dest As Any Ptr=0,im As Any Ptr,angle As Single,shiftx As Long=0,shifty As Long=0,sc As Single=1,miss As Ulong=Rgb(255,0,255),fixedpivot As boolean=false)
2. error 41: Variable not declared, false in 'If fixedpivot=false Then
3. error 41: Variable not declared, true in 'rotateimage(,i,-n,50*n-100,300,f,,true) '<--- scaled/rotated image here'
(My system:
FBIde: 0.4.6
fbc: FreeBASIC Compiler - Version 1.01.0 (12-28-2014), built for win32 (32bit)
OS: Windows NT 6.2 (build 9200)
)

P.S.: as I see, you used a function called "Regulate" to set the fps for the application. Can this be used for set of delta time in any FB program?
fxm
Moderator
Posts: 12577
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: Image resizing

Post by fxm »

The boolean type is only available from fbc version 1.04.
So update your FreeBASIC to the latest version (1.10.1)
dafhi
Posts: 1741
Joined: Jun 04, 2005 9:51

Re: Image resizing

Post by dafhi »

very cool dodicat! the quality is amazing. might have a look later to see if i can grok what it's doing, then maybe make a run-length version of it at a (perhaps) much later date.

Code: Select all


Sub rotateimage(Byref dest As Any Ptr=0,im As Any Ptr,angle As Single,shiftx As Long=0,shifty As Long=0,sc As Single=1,miss As Ulong=Rgb(255,0,255),fixedpivot As boolean=false)
    Static As Integer pitch,pitchs,xres,yres,runflag
    Static As Any Ptr row,rows
    Static As Integer ddx,ddy,resultx,resulty
    Imageinfo im,ddx,ddy,,pitch,row
    If dest=0 Then
    Screeninfo xres,yres,,,pitchS
    rowS=Screenptr
    Else
    If sc<>1 Then 
        Dim As Integer x,y
        Imageinfo dest,x,y
    Imagedestroy dest:dest=0: dest=Imagecreate(x*sc,y*sc)
    End If
    Imageinfo dest, xres,yres,,pitchS,rows
    End If
    Dim As Long centreX=ddx\2,centreY=ddy\2
    Dim As Single sx=Sin(angle)
    Dim As Single cx=Cos(angle)
    Dim As Long mx=Iif(ddx>=ddy,ddx,ddy),shftx,shfty
    Var fx=sc*.7071067811865476,sc2=1/sc
    If fixedpivot=false Then
     shiftx+=centreX*sc-centrex
     shiftY+=centrey*sc-centrey
     End If
    For y As Long=centrey-fx*mx+1 To centrey+ fx*mx 
        Dim As Single sxcy=Sx*(y-centrey),cxcy=Cx*(y-centrey)
        shfty=y+shifty
        For x As Long=centrex-mx*fx To centrex+mx*fx 
                 If x+shiftx >=0 Then 'on the screen
                    If x+shiftx <xres Then
                        If shfty >=0 Then
                            If shfty<yres Then
            resultx=sc2*(Cx*(x-centrex)-Sxcy) +centrex:resulty=sc2*(Sx*(x-centrex)+Cxcy) +centrey
                If resultx >=0 Then 'on the image
                    If resultx<ddx Then
                        If resulty>=0 Then
                            If resulty<ddy Then
    Dim As Ulong u=*Cast(Ulong Ptr,row+pitch*((resultY))+((resultX)) Shl 2 ) 'point(image)
   If u<>miss Then *Cast(Ulong Ptr,rowS+pitchS*(y+shifty)+(x+shiftx) Shl 2)= u 'pset (screen)
                End If:End If:End If:End If
                End If:End If:End If:End If
        Next x
    Next y
End Sub

Function Regulate(Byval MyFps As Long,Byref fps As Long=0) As Long
    Static As Double timervalue,_lastsleeptime,t3,frames
    Var t=Timer
    frames+=1
    If (t-t3)>=1 Then t3=t:fps=frames:frames=0
    Var sleeptime=_lastsleeptime+((1/myfps)-T+timervalue)*1000
    If sleeptime<1 Then sleeptime=1
    _lastsleeptime=sleeptime
    timervalue=T
    Return sleeptime
End Function



Screenres 1060,762,32

Var i=Imagecreate(200,200),i2=Imagecreate(1060,762,rgb(0,100,0))
#define range(f,l) Rnd*((l)-(f))+(f)
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
For n As Long=0 To 762-200  'background to i2
        Var red=map(0,762,n,0,255)
        Var green=map(0,762,n,0,255)
        Var blue=map(0,762,n,220,255)
        Line i2,(0,n)-(1060,n),Rgb(red,green,blue)
    Next
    'axe to i
Var col=Rgb(110,53,0),s=Rgb(140,140,140)
Circle i,(169,150-15),25+12,s,4.1,5.3
Line i,(160,75)-(165,75),s
Line i,(160,75)-(149,165),s
Line i,(165,75)-(189,165),s
Line i,(149,165)-(189,165),s
Paint i,(170,150),s,s
Paint i,(162,80),s,s
Paint i,(180,167),s,s
For x As Long=30 To 80 Step 10
    Circle i,(x,100),7,Rgb(100,40,0),,,,f
    Next
Line i,(10,95)-(190,105),col,bf

Do
Var f=range(.2,2)
Dim As Double n
dim as long fps
Do
    n+=f/10
    Screenlock
    Put(0,0),i2,Pset
  Put(0,-70),i,trans 
  Draw String(200,20),"ORIGINAL"
  Draw String(400,20),"Magnifacation  " & f
  Draw String(800,20),"Framerate " & fps
randomize 1
for j as long = 1 to 50
dim as long x = rnd * 1000
dim as long y = rnd * 800
rotateimage(,i,-n,x,y,f,,true) '<--- scaled/rotated image here
next
'rotateimage(,i,-n,50*n-100,300,f,,true) '<--- scaled/rotated image here
Screenunlock
Sleep regulate(30,fps)
If Len(Inkey) Then Exit Do,Do
Loop Until 50*n>900
Sleep 500
Cls
Loop Until Len(Inkey)
imagedestroy i
imagedestroy i2
 
ITomi
Posts: 189
Joined: Jul 31, 2015 11:23
Location: Hungary

Re: Image resizing

Post by ITomi »

fxm wrote: Feb 25, 2025 13:59 The boolean type is only available from fbc version 1.04.
So update your FreeBASIC to the latest version (1.10.1)
Thanks, Fxm; I changed boolean to ubyte and true and false to 1 and 0 in it, and the program is now running properly.
Very cool!
Is it possible to make it the axe go in a curve path? Is there an example program for this somewhere?
fxm
Moderator
Posts: 12577
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: Image resizing

Post by fxm »

fxm wrote: Feb 23, 2025 13:17 Why not only use the graphical instruction pair:
'View' / 'Window Screen'
and just draw the image at the right size in the clipping area.
This way we can use a non-integer zoom factor!

Code: Select all

#include "fbgfx.bi"
Using FB

Dim As Double zoom = 1 '' zoom factor of destination image

Screenres 640, 480, 32

Sub DrawImage() '' drawing 32*32
    Circle (16, 16), 15, RGB(255, 255, 0),     ,     , 1, f
    Circle (10, 10), 3,  RGB(  0,   0, 0),     ,     , 2, f
    Circle (22, 10), 3,  RGB(  0,   0, 0),     ,     , 2, f
    Circle (16, 18), 10, RGB(  0,   0, 0), 3.14, 6.28
End Sub


Do
    Var k = Inkey
    Select Case k
        Case Chr(255) & "H" 'Up arrow
            If zoom < 14 Then
                zoom += 0.25
            End If
        Case Chr(255) & "P" 'Down arrow
            If zoom > 1 Then
                zoom -= 0.25
            End If
    End Select
    Screenlock
    Cls
    View(0, 24)-(0 + 32 * zoom - 1, 24 + 32 * zoom - 1)
    Window Screen(0, 0)-(32, 32)
    DrawImage()
    View
    Window
    Draw String (1, 1),"Use 'UP' and 'DOWN' arrow keys to resize image; 'ESC' to exit."
    Draw String (1, 12),"Zoom factor of the destination image: " & Str(zoom)
    Screenunlock
    Sleep 10
Loop Until Multikey(sc_escape)

Sleep

With the same principle ('View' / 'Window Screen'), it is possible to zoom (with also a non-integer factor) any raw image only from its pixel colors, by redrawing a stretched colored box for each pixel (and adding on the bottom and right side the background color to remove the border effects).

Code: Select all

#include "fbgfx.bi"
Using FB

Dim As Double zoom = 1 '' zoom factor of destination image
Dim As Any Ptr pimg  '' pointer to image buffer
Dim Shared As Ulong col(0 To 31+1, 0 To 31+1)  '' color (32+1)*(32+1)

Screenres 640, 480, 32

pimg = Imagecreate(32, 32, 0)  '' image 32*32
Circle pimg, (16, 16), 15, RGB(255, 255, 0),     ,     , 1, f
Circle pimg, (10, 10), 3,  RGB(  0,   0, 0),     ,     , 2, f
Circle pimg, (22, 10), 3,  RGB(  0,   0, 0),     ,     , 2, f
Circle pimg, (16, 18), 10, RGB(  0,   0, 0), 3.14, 6.28

For I As Integer = 0 To 31
    For J As Integer = 0 To 31
        col(I, J) = Point(I, J, pimg)  '' image
    Next J
Next I

For I As Integer = 0 To 31+1
    col(I, 31+1) = 0  '' backgroung
Next I
For J As Integer = 0 To 31+1
    col(31+1, J) = 0  '' background
Next J

Sub RedrawImage()  '' redrawing (32+1)*(32+1)
    For I As Integer = 0 To 31+1
        For J As Integer = 0 To 31+1
            Line(I, J)-Step(1, 1), col(I, J), BF
        Next J
    Next I
End Sub


Do
    Var k = Inkey
    Select Case k
        Case Chr(255) & "H" 'Up arrow
            If zoom < 14 Then
                zoom += 0.25
            End If
        Case Chr(255) & "P" 'Down arrow
            If zoom > 1 Then
                zoom -= 0.25
            End If
    End Select
    Screenlock
    Cls
    View(0, 24)-(0 + 32 * zoom - 1, 24 + 32 * zoom - 1)
    Window Screen(0, 0)-(32, 32)
    RedrawImage()
    View
    Window
    Draw String (1, 1),"Use 'UP' and 'DOWN' arrow keys to resize image; 'ESC' to exit."
    Draw String (1, 12),"Zoom factor of the destination image: " & Str(zoom)
    Screenunlock
    Sleep 10
Loop Until Multikey(sc_escape)

Imagedestroy pimg
Sleep
ITomi
Posts: 189
Joined: Jul 31, 2015 11:23
Location: Hungary

Re: Image resizing

Post by ITomi »

But wait, Fxm! Can I use the resized image in the other parts of the program or is this 'View' / 'Window Screen' just a picture viewing solution?
As I can see, your code doesn't make a copy of the image.
fxm
Moderator
Posts: 12577
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: Image resizing

Post by fxm »

From the pixel colors of the original image, a resized image can be directly put in an image buffer (using 'Window Screen' only), then this image buffer can be copied anywhere on the screen.

Code: Select all

#include "fbgfx.bi"
Using FB

Dim As Double zoom = 1 '' zoom factor of destination image
Dim As Any Ptr pimg  '' pointer to image buffer
Dim Shared As Ulong col(0 To 31+1, 0 To 31+1)  '' color (32+1)*(32+1)

Screenres 640, 480, 32

pimg = Imagecreate(32, 32, 0)  '' image 32*32
Circle pimg, (16, 16), 15, RGB(255, 255, 0),     ,     , 1, f
Circle pimg, (10, 10), 3,  RGB(  0,   0, 0),     ,     , 2, f
Circle pimg, (22, 10), 3,  RGB(  0,   0, 0),     ,     , 2, f
Circle pimg, (16, 18), 10, RGB(  0,   0, 0), 3.14, 6.28

For I As Integer = 0 To 31
    For J As Integer = 0 To 31
        col(I, J) = Point(I, J, pimg)  '' image
    Next J
Next I

For I As Integer = 0 To 31+1
    col(I, 31+1) = 0  '' backgroung
Next I
For J As Integer = 0 To 31+1
    col(31+1, J) = 0  '' background
Next J

Sub RedrawImage(Byval p As Any Ptr)
    For I As Integer = 0 To 31+1
        For J As Integer = 0 To 31+1
            Line p, (I, J)-Step(1, 1), col(I, J), BF
        Next J
    Next I
End Sub


Do
    Var k = Inkey
    Select Case k
        Case Chr(255) & "H" 'Up arrow
            If zoom < 14 Then
                zoom += 0.25
            End If
        Case Chr(255) & "P" 'Down arrow
            If zoom > 1 Then
                zoom -= 0.25
            End If
    End Select
    
    ' resized image put in an image buffer
    Window Screen(0, 0)-(32, 32)
    Dim As Any Ptr p = Imagecreate(32 * zoom, 32 * zoom, 0)
    RedrawImage(p)
    Window
    
    ' image buffer put on the screen
    Screenlock
    Cls
    Put (0, 24), p
    Draw String (1, 1),"Use 'UP' and 'DOWN' arrow keys to resize image; 'ESC' to exit."
    Draw String (1, 12),"Zoom factor of the destination image: " & Str(zoom)
    Screenunlock
    ImageDestroy p
    Sleep 10
Loop Until Multikey(sc_escape)

Imagedestroy pimg
Sleep
Post Reply