## Simple FBImage / Sprite scaling in Basic

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
D.J.Peters
Posts: 7822
Joined: May 28, 2005 3:28

### Simple FBImage / Sprite scaling in Basic

Code: Select all

#include "fbgfx.bi"
'
'  NewImage = ImageScale(SourceImage,Scale)
'
Function ImageScale(s As fb.Image Ptr, Scale as single=1.0) As fb.Image Ptr
static As fb.Image Ptr t=0
If s        =0 Then Return 0
If s->width <1 Then Return 0
If s->height<1 Then Return 0
scale=abs(scale)
dim as integer w = s->width *Scale
dim as integer h = s->height*Scale
If w<4 Then w=4
If h<4 Then h=4
if t then ImageDestroy(t) : t=0
t=ImageCreate(w,h)
Dim As Integer xs=(s->width /t->Width ) * (1024*64)
Dim As Integer ys=(s->height/t->height) * (1024*64)
Dim As Integer x,y,sy
Select Case As Const s->bpp
Case 4
Dim As Ulong Ptr ps=cptr(Ulong Ptr,s)+8
Dim As Uinteger     sp=(s->pitch Shr 2)
Dim As Ulong Ptr pt=cptr(Ulong Ptr,t)+8
Dim As Uinteger     tp=(t->pitch Shr 2)-t->width
For ty As Integer = 0 To t->height-1
Dim As Ulong Ptr src=ps+(sy Shr 16)*sp
For tx As Integer = 0 To t->width-1
*pt=src[x Shr 16]:pt+=1:x+=xs
Next
pt+=tp:sy+=ys:x=0
Next
Case 2
Dim As Ushort Ptr ps=cptr(Ushort Ptr,s)+16
Dim As Uinteger   sp=(s->pitch Shr 1)
Dim As Ushort Ptr pt=cptr(Ushort Ptr,t)+16
Dim As Uinteger   tp=(t->pitch Shr 1)-t->width
For ty As Integer = 0 To t->height-1
Dim As Ushort Ptr src=ps+(sy Shr 16)*sp
For tx As Integer = 0 To t->width-1
*pt=src[x Shr 16]:pt+=1:x+=xs
Next
pt+=tp:sy+=ys:x=0
Next
Case 1
Dim As Ubyte Ptr ps=cptr(Ubyte Ptr,s)+32
Dim As Uinteger   sp=s->pitch
Dim As Ubyte Ptr pt=cptr(Ubyte Ptr,t)+32
Dim As Uinteger   tp=t->pitch-t->width
For ty As Integer = 0 To t->height-1
Dim As Ubyte Ptr src=ps+(sy Shr 16)*sp
For tx As Integer = 0 To t->width-1
*pt=src[x Shr 16]:pt+=1:x+=xs
Next
pt+=tp:sy+=ys:x=0
Next
End Select
Return t
End Function

#define FULLSCREEN 1
#define SCR_W 1024
#define SCR_H 768

type BALL2D
declare constructor (radius as integer=32)
declare sub Draw
as single size,x,y,z
as fb.Image ptr Img
end type

constructor BALL2D (radius as integer=32)
dim as uinteger col = RGB(rnd*256,rnd*256,rnd*256)
dim as integer r=radius
dim as single be = col and &HFF,blue =be/4:col shr=8
dim as single ge = col and &HFF,green=ge/4:col shr=8
dim as single re = col and &HFF,red  =re/4
dim as single rs = red/r*3,gs=green/r*3,bs=blue/r*3
img=ImageCreate(size,size)
while r
r-=1:
red+=rs:green+=gs:blue+=bs
wend
end constructor

sub BALL2D.Draw
' behind the observer ?
if z<1 then return
dim as single ScreenX    = x*256       /z
dim as single ScreenSize =(x+Size)*256 /z
dim as single ScreenY    = y*256       /z
ScreenSize-=ScreenX
ScreenX=SCR_W/2 + ScreenX
ScreenY=SCR_H/2 + ScreenY
' scale factor
dim as single Scale = ScreenSize/Size
dim as single ScreenRadius = ScreenSize*0.5
' up or down scale
put (ScreenX,ScreenY),ImageScale(img,Scale),TRANS
end sub

type BALL_CHAIN
declare constructor(n as integer=100)
declare sub Update(w as single)
declare sub Draw
as single wstep
as integer nBalls,nSorted
as BALL2D ptr  pBalls
as integer ptr pSorted
end type
constructor BALL_CHAIN(n as integer)
this.nBalls = n
pBalls = new BALL2D[nBalls]
pSorted = new INTEGER[nBalls]
wstep = 1.57/nBalls
end constructor
sub BALL_CHAIN.Update(w as single)
nSorted=0
for i as integer=0 to nBalls-1
pBalls[i].z = 828+sin(w)*700
if pBalls[i].z>1 then
pBalls[i].x = cos(w*4)*500
pBalls[i].y = sin(w*8)*200
pSorted[nSorted]=i
nSorted+=1
end if
w+=wStep
next

if nSorted>1 then
dim as integer flag=1
while flag
flag=0
for i as integer=0 to nSorted-2
if pBalls[pSorted[i]].z < pBalls[pSorted[i+1]].z then
swap pSorted[i],pSorted[i+1]
flag = 1
exit for
end if
next
wend
end if
end sub
sub BALL_CHAIN.Draw
if nSorted<1 then return
for i as integer=0 to nSorted-1
pBalls[pSorted[i]].Draw
next
end sub

Screenres SCR_W,SCR_H,32,,IIF(FULLSCREEN,1,0)

dim as BALL_CHAIN Ballchain

dim as single w=-1.57

while inkey=""
screenlock:cls
BallChain.Draw
screenunlock
BallChain.Update(w)
w=w+0.005
sleep 10
wend
Last edited by D.J.Peters on Nov 18, 2017 19:02, edited 4 times in total.
rolliebollocks
Posts: 2655
Joined: Aug 28, 2008 10:54
Location: new york
Your example is freaken awesome. Thanks for this...
cha0s
Posts: 5317
Joined: May 27, 2005 6:42
Location: Illinois
Contact:
Cool ^^
Munair
Posts: 836
Joined: Oct 19, 2017 15:00
Location: 't Zand, NL
Contact:

### Re: Simple FBImage / Sprite scaling in Basic

IT CRASHES THE DESKTOP ON MY LINUX SYSTEM, SETTING THE SCREEN TO 1024x768.
NO LONGER SAFE TO RUN THIS CODE WITHOUT MODIFICATION.
D.J.Peters
Posts: 7822
Joined: May 28, 2005 3:28

### Re: Simple FBImage / Sprite scaling in Basic

Munair wrote:IT CRASHES THE DESKTOP ON MY LINUX SYSTEM
It's 7 years old the time of 32-bit only :-)

It's Integer ptr vs Ulong ptr on 64-bit is fixed now

Joshy

Code: Select all

Case 4
Dim As Ulong Ptr ps=cptr(Ulong Ptr,s)+8 ' <-- Integer vs ulong ptr
Dim As Uinteger     sp=(s->pitch Shr 2)
Dim As Ulong Ptr pt=cptr(Ulong Ptr,t)+8 ' <-- Integer vs ulong ptr
Dim As Uinteger     tp=(t->pitch Shr 2)-t->width
For ty As Integer = 0 To t->height-1
Dim As Ulong Ptr src=ps+(sy Shr 16)*sp
For tx As Integer = 0 To t->width-1
*pt=src[x Shr 16]:pt+=1:x+=xs
Next
pt+=tp:sy+=ys:x=0
Next