got my zoomer working though.
I'm not certain if it's the quality of my sampler or some kind of x y w h miscalculation at image transition
Code: Select all
' ------- uses GDI+ to load jpg
#Ifndef Floor
#Define Floor(x) (((x) * 2.0 - 0.5) Shr 1) '' http://www.freebasic.net/forum/viewtopic.php?p=118633
#Define Ceiling(x) (-((-(x) * 2.0 - 0.5) Shr 1))
#EndIf
Union UnionARGB
As Ulong col: Type: As UByte B,G,R,A: End Type
End Union
Type sng2D
As Single x,y
End Type
type myint as integer
type imagevars '2017 Jan 7 - by dafhi
as myint w,h,bpp,bypp,pitch,rate, wm, hm, pitchBy, num_pages, flags 'helpers
as any ptr im, pixels
as ulong ptr p32
as string driver_name
declare sub get_info(im as any ptr=0)
as single wh, hh, diagonal
declare sub screen_init(w as myint=0, h as myint=0, bpp as myint=32, npages as myint=1, flags as myint=0)
declare sub create(w as myint=0, h as myint=0, col as ulong=&HFF000000)
Declare Sub SkewRect_ScaleRotate(ByVal scale_ As Single = 1.0, ByVal angle_ As Single = 0.0)
Declare Sub SkewRect_Render(ByRef dest As imagevars ptr, _
ByVal x As myint = 0, _
ByVal y As myint = 0, _
ByVal wid As myint = -1, _
ByVal hgt As myint = -1)
declare destructor
private:
As sng2D ptA,ptB,ptC,ptD
declare sub destroy
end type
Destructor.imagevars: destroy
End Destructor
Sub imagevars.Destroy(): If ImageInfo(im) = 0 <> 0 Then ImageDestroy im: im = 0: endif: End Sub
sub imagevars.get_info(im as any ptr)
if im=0 then
pixels=screenptr: ScreenInfo w,h, bpp, bypp, pitch, rate, driver_name
elseif Imageinfo(im)=0 then
ImageInfo im, w, h, bypp, pitch, pixels
bpp = bypp * 8: this.im = im
endif: pitchBy=pitch\bypp
wm=w-1: wh=w/2: diagonal = sqr(w*w+h*h)
hm=h-1: hh=h/2: p32=pixels
end sub
sub imagevars.create(w as myint, h as myint, col as ulong)
destroy: get_info imagecreate(w,h,col)
End Sub
Sub imagevars.screen_init(w As myint, h As myint, _bpp as myint, _pages as myint, _flags as myint)
Destroy: ScreenRes w,h,_bpp,_pages,_flags: get_info
num_pages=_pages: flags=_flags: if num_pages > 1 then screenset 0,1
End sub
Sub imagevars.SkewRect_ScaleRotate(ByVal scale_ As Single, ByVal angle_ As Single)
If scale_ = 0 Then Exit Sub
scale_ = 1 / scale_
Dim As Single xLeft = wh * -scale_
Dim As Single xRight = wh * scale_
Dim As Single yTop = hh * -scale_
Dim As Single yBot = hh * scale_
Dim As Single cos_ = Cos( -angle_ )
Dim As single sin_ = Sin( -angle_ )
Dim As Single tmpA,tmpB
#Macro Rot8_Trans(init_a,init_b,dsta, dstb)
dsta = init_a
dstb = init_b
tmpA = cos_ * dsta + sin_ * dstb
tmpB = cos_ * dstb - sin_ * dsta
dsta = tmpA + wh + .5
dstb = tmpB + hh + .5
#EndMacro
Rot8_Trans( xLeft, yTop, ptA.x, ptA.y )
Rot8_Trans( xRight, yTop, ptB.x, ptB.y )
Rot8_Trans( xLeft, yBot, ptC.x, ptC.y )
Rot8_Trans( xRight, yBot, ptD.x, ptD.y )
End Sub
Sub imagevars.SkewRect_Render(ByRef pDest As imagevars ptr, _
ByVal x As myint, ByVal y As myint, _
ByVal wid_ As myint, ByVal hgt_ As myint)
#Macro InterpolatePoint(dest_,from_,to_)
dest_.x = from_.x + lerp * (to_.x - from_.x)
dest_.y = from_.y + lerp * (to_.y - from_.y)
#EndMacro
#Macro LayerSource_Components(aa_mul1, aa_mul2)
aa_fractional = aa_mul1 * aa_mul2
sRed += aa_fractional * ptrSource->R
sGrn += aa_fractional * ptrSource->G
sBlu += aa_fractional * ptrSource->B
#EndMacro
#Macro BoundsCheckSource(aa_mul1, aa_mul2)
If srcY >= 0 Then
If srcX >= 0 Then
If srcY < h Then
If srcX < w Then
LayerSource_Components( aa_mul1, aa_mul2 )
'c += 1
EndIf
EndIf
EndIf
EndIf
#EndMacro
Dim As myint clipLeft,clipTop,xLeft=floor(x+.5),yTop=floor(y+.5)
If x < 0 Then clipLeft = -x: xLeft = 0
If y < 0 Then clipTop = -y: yTop = 0
Dim As myint widM_ = wid_ - 1
Dim As myint hgtM_ = hgt_ - 1
Dim As myint xRight = xleft + widM_
Dim As myint yBot = ytop + hgtM_
If xRight > pDest->wM Then xRight = pDest->wM
If yBot > pDest->hM Then yBot = pDest->hM
Dim As Single aa_fractional, xGridStep = 1 / (wid_) '2018 Jan 8
For yDest As myint = yTop To yBot
Dim As myint yGrid = yDest + ClipTop
Dim As single lerp = (yGrid - yTop) / (hgt_) '2018 Jan 8
Dim As sng2D ptAC, ptBD
InterpolatePoint( ptAC, ptA, ptC )
InterpolatePoint( ptBD, ptB, ptD )
Dim As UnionARGB Ptr pixDest = pDest->pixels + yDest * pDest->pitch
For xDest As myint = xLeft To xRight
Dim As myint xGrid = xDest + ClipLeft
Dim As sng2D srcFloatPos
lerp = (xGrid - xLeft) * xGridStep
InterpolatePoint( srcFloatPos, ptAC, ptBD )
Dim As myint srcX = floor(srcFloatPos.x)
Dim As myint srcY = floor(srcFloatPos.y)
Dim As Single aa_Left = srcX + 1 - srcFloatPos.x
Dim As Single aa_Top = srcY + 1 - srcFloatPos.y
Dim As Single aa_Right = 1 - aa_Left
Dim As Single aa_Bot = 1 - aa_Top
Dim As Single sRed, sGrn, sBlu
Dim As UnionARGB ptr ptrSource = pixels
ptrSource += srcY * pitchBy + srcX
'var c = 0 '2018 Jan 8
BoundsCheckSource( aa_Left, aa_Top ) ''A
srcX += 1
ptrSource += 1
BoundsCheckSource( aa_Right, aa_Top ) ''B
srcY += 1
ptrSource += pitchBy
BoundsCheckSource( aa_Right, aa_Bot ) ''D
srcX -= 1
ptrSource -= 1
BoundsCheckSource( aa_Left, aa_Bot ) ''C
'if c>0 then
pixDest[xDest].B = sBlu
pixDest[xDest].G = sGrn
pixDest[xDest].R = sRed
'endif
Next
Next
End Sub
function round(in as single, places as ubyte = 2) as single
dim as integer mul = 10 ^ places
return int(in * mul + .5) / mul
End Function
#if sizeof(integer)=8
#include "windows.bi"
#endif
#Include "win/gdiplus.bi"
type bar
as single start,finish,variable
as uinteger fillcol,rimcol
end type
sub proBar(startx as integer,starty as integer,length as integer,thickness as integer,B as bar)
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
var xpos=map(b.start,b.finish,b.variable,startx,(startx+length))
line(startx,starty)-(xpos,starty+thickness),B.fillcol,bf
line(startx-1,starty-1)-(startx+length+1,starty+thickness+1),b.rimcol,b
end sub
dim as bar z
z.start=0
z.finish=48
z.fillcol=rgb(200,100,0)
z.rimcol=rgb(200,200,200)
'An idea from UEZ in another thread.
Function Pload(file as String,byref i as any ptr=0) as long
#define putpixel(_x,_y,colour) *cptr(ulong ptr,row+ (_y)*pitch+ (_x) shl 2) =(colour)
static as integer pitch
static as any ptr row
Imageinfo i,,,,pitch,row
Dim As uinteger TMP
GDIPLUS.GdiplusStartup(@TMP,@type<GDIPLUS.GDIPLUSSTARTUPINPUT>(1),0)
Dim as any Ptr Img
if GDIPLUS.GdipLoadImageFromFile(file,@Img)>0 then return 0
Dim As Single w,h
GDIPLUS.GdipGetImageDimension(Img,@w,@h)
if w*h=0 then return 0
Dim As GDIPLUS.BitmapData Pdata
Dim As Rect R=Type(0,0,w-1,h-1)
GDIPLUS.GdipBitmapLockBits(Img,Cast(Any Ptr,@R),GDIPLUS.ImageLockModeRead,PixelFormat32bppARGB,@Pdata)
For y as long = 0 To h-1
For x as long = 0 To w-1
'pset i,(x,y),Cast(ulong Ptr,Pdata.Scan0)[y*w+x]
putpixel(x,y,(Cast(ulong Ptr,Pdata.Scan0)[y*w+x]))
Next
Next
return w*h
End Function
function resize(im As Any Ptr,Wdth As Single,Hght as single) as any ptr
#define putpixel(_x,_y,colour) *cptr(ulong ptr,rowS+ (_y)*pitchS+ (_x) shl 2) =(colour)
#define _getpixel(_x,_y) *cptr(ulong ptr,row + (_y)*pitch + (_x) shl 2)
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))\((b)-(a))+(c)
static As Integer pitch,pitchs
static As Any Ptr row,rowS
static As Ulong Ptr pixel,pixels
static As Integer ddx,ddy,resultx,resulty
Imageinfo im,ddx,ddy,,pitch,row
dim as any ptr im2=imagecreate(Wdth,Hght)
imageinfo im2,,,,pitchS,rowS
For y As long=0 To Hght-1
resulty=map(0,Hght,y,0,ddy)
For x As long=0 To Wdth-1
resultx=map(0,Wdth,x,0,ddx)
putpixel(x,y,_getpixel(resultx,resulty))
Next x
Next y
return im2
End function
'text
sub text(x as long,y as long,s as string,e as single=1,col as ulong=-1,alph as ubyte=255)
dim as any ptr i=imagecreate(8*len(s),16)
draw string i,(0,0),s,col
i=resize(i,e*8*len(s),e*16)
put(x,y),i,alpha,alph
imagedestroy i
end sub
dim as imagevars buf: buf.screen_init 960,720
dim as single w=1200,h=900
var uc = 48
dim as imagevars imv(uc-1)
imv(0).create w,h
chdir exepath
if Pload("images/arkadia0.jpg", imv(0).im) =0 then print "unable to load":sleep:end 'TEST IF IMAGES ARE AVAILABLE.
text(500,300,"Please wait ...",2,rgb(255,255,255))
for n as long=1 to uc-1
z.variable=n 'n always lies between start and finish
proBar(500,350,200,10,z)
with imv(n)
.create w,h
Pload( "images/arkadia"+str(n)+".jpg", .im )
end with
if inkey<>"" then exit for
next
type blitrect
as myint x,y,w,h
as imagevars ptr pdest
as single iscale
declare sub vals(byref as imagevars ptr, as single=0)
declare sub blit(byref as imagevars ptr)
declare constructor(byref as imagevars ptr=0, as single=0)
End Type
constructor.blitrect(byref dest as imagevars ptr, scale as single)
if dest<>0 then vals dest, scale
end constructor
sub blitrect.vals(byref dest as imagevars ptr, _scale as single)
w = int(dest->w * _scale * 2 + .5) \ 2
h = int(dest->h * _scale * 2 + .5) \ 2
x = (dest->w - w) \ 2
y = (dest->h - h) \ 2
iscale = dest->diagonal / sqr(w*w+h*h)
pdest = dest
End Sub
sub blitrect.blit(byref src as imagevars ptr)
src->skewRect_Render pdest, x, y, w,h
End Sub
dim as blitrect rc_2 = type(@buf, 1/2)
dim as blitrect rc_4 = type(@buf, 1/4)
dim as single td0, td1, fps_report_interval = 1
dim as double trigger_report = timer
Dim as Single b
do
var c = 2^Frac(b), angle = 0, t = timer
screenlock
For e as long = 0 to 2
var a = (Floor(b) + e) Mod uc
select case e: case 0
imv(a).skewRect_ScaleRotate c,angle
imv(a).skewRect_Render @buf, 0,0,buf.w,buf.h
case 1
imv(a).skewRect_ScaleRotate c*rc_2.iscale,angle
rc_2.blit @imv(a)
case 2
imv(a).skewRect_ScaleRotate c*rc_4.iscale,angle
rc_4.blit @imv(a)
end select
c *= 0.5
Next
var t2 = timer
if t2 >= trigger_report then
td0 = td1
td1 = t2-t
trigger_report += fps_report_interval
endif
text 5, 5, "fps " & round(2/(td1+td0))
screenunlock
b += 0.01
b -= uc*int(b/uc) '' mod .. uc = 48
sleep 1
loop until len(inkey)