UEZ wrote:No, there are usually two kind of same functions in the GDI+ lib. One is integer, the 2nd one is float.
Code: Select all
CPU GdipDrawImageRectI 8BFF mov edi, edi ; start of "integer version"
... (26 instructions converting integers to floats) ...
708DE25A E8 49FEFFFF call GdipDrawImageRect ; oops!Excellent, thanks.GdipSetInterpolationMode is the magic function
Code: Select all
#if sizeof(integer)=8
#include "windows.bi"
#endif
#Include "win/gdiplus.bi"
Declare Function setT Alias "timeBeginPeriod"(As Ulong=1) As Long
Declare Function freeT Alias "timeEndPeriod" (As Ulong=1) As Long
type bar
as single start,finish,variable
as uinteger fillcol,rimcol
end type
sub ShowBar(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)
screenres 1200,900,32
'An idea from UEZ in another thread.
Function PloadToImage(Picture as String,byref i as any ptr) 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(Picture,@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
sub getsize(picture as string,byref w as single,byref h as single) 'unused
Dim As uinteger TMP
GDIPLUS.GdiplusStartup(@TMP,@type<GDIPLUS.GDIPLUSSTARTUPINPUT>(1),0)
Dim as any Ptr Img
if GDIPLUS.GdipLoadImageFromFile(Picture,@Img)>0 then exit sub
GDIPLUS.GdipGetImageDimension(Img,@w,@h)
end sub
Function Regulate(Byval MyFps As long,Byref fps As long) As long
Static As Double timervalue,_lastsleeptime,t3,frames
frames+=1
If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
Var sleeptime=_lastsleeptime+((1/myfps)-Timer+timervalue)*1000
If sleeptime<1 Then sleeptime=1
_lastsleeptime=sleeptime
timervalue=Timer
Return sleeptime
End Function
function resize(im As Any Ptr,Wdth As Single,Hght as single,dx as long=0,dy as long=0) 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-dx,Hght-dy)
imageinfo im2,,,,pitchS,rowS
For y As long=0+dy To Hght-1 -dy
resulty=map(0,Hght,y,0,ddy)
For x As long=0+dx To Wdth-1 -dx
resultx=map(0,Wdth,x,0,ddx)
putpixel(x,y,_getpixel(resultx,resulty))
Next x
Next y
return im2
End function
'text
sub show(x as long,y as long,s as string,e as single=1,col as ulong,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 string file="images/arkadia0.jpg"
dim as any ptr pict=imagecreate(1200,900)
if PloadToImage(file,pict) =0 then print "unable to load":sleep:end 'TEST IF IMAGES ARE AVAILABLE.
put(0,0),pict
show(500,300,"Please wait ...",2,rgb(255,255,255))
dim as integer w,h
screeninfo w,h
dim as any ptr im(0 to 48),tmp
for n as long=0 to 48
z.variable=n 'n always lies between start and finish
ShowBar(500,350,200,10,z)
im(n)=imagecreate(w,h)
file="images/arkadia"+str(n)+".jpg"
PloadToImage(file,im(n))
next
dim as single x,y,number
dim as long fps,myfps,c,mwheel,rflag,btn
dim as integer ww,hh
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))\((b)-(a))+(c)
#define resetwheel(w,fl) fl=w
#define wheel(w,f) w-f
do
getmouse c,c,mwheel,btn
mwheel=abs(4*mwheel)
if btn then resetwheel(mwheel,rflag)
mwheel=wheel(mwheel,rflag)
if (w+x)>=w*2 then number+=1:x=0:y=0 'double scale
number=number mod 49
tmp=resize(im(number),w+x,h+y,x\2,y\2)
screenlock
cls
put(-x\2,-y\2),tmp,pset
show 600,300,"FPS " &fps,2,rgb(255,255,255)
draw string(600,320),str(number) + " of 48",rgb(255,255,255)
draw string(600,340),"Wheel boost "&abs(mwheel)
screenunlock
x+=8+abs(mwheel)
y+=(8+abs(mwheel))*.75
myfps=map(0,1200,x,25,40)
setT
sleep regulate(myfps,fps)
freeT
imagedestroy tmp
loop until len(inkey)
for n as long=0 to 48
imagedestroy(im(n))
next
imagedestroy pict
sleep
I changed the variable for desktop w/h to your dimension and now I see what you mean with folding. But when I remove the multiplier 0.75 then the ratio (w / h) of image will get corrupted and the sun looks like an ellipse.dodicat wrote:Thanks UEZ.
You still have folding at the frame top (and bottom).
If r = 0.75 * iW_Dt is changed to
r = iW_Dt both times,(i.e. drop the .75) it seems to get rid of it here.
My desktop is 1290 by 1024.
Code: Select all
Sub Tree(x1 As Single,y1 As Single,size As Single,angle As Single,depth As Single,colb As ulong=0,colL As ulong=0,im as any ptr=0)
Dim As Single spread,scale,x2,y2
spread=25
scale=.76
#define incircle(cx,cy,radius,x,y) (cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
x2=x1-.25*size*Cos(angle*.01745329)
y2=y1-.25*size*Sin(angle*.01745329)
Static As Integer count,fx,fy,sz,z
If count=0 Then fx=x1:fy=y1:sz=size:z=2^(depth+1)-1
Line im,(x1,y1)-(x2,y2),colb
If count=0 Then fx=x2:fy=y2:sz=size
count=count+1
If count>z Then count=0
If incircle(fx,fy,(.45*sz),x2,y2)=0 Then Circle im,(x2,y2),.01*sz,colL
If depth>0 Then
Tree(x2, y2, size * Scale, angle - Spread, depth - 1,colB,colL,im)
Tree(x2, y2, size * Scale, angle + Spread, depth - 1,colB,colL,im)
End If
End Sub
screen 19
dim as any ptr i=imagecreate(350,350)
line i,(20,20)-(300,300),7,bf
Tree(180,250,200,80,12,0,6,i)
put(50,50),i,pset
Tree(500,350,100,100,12,4,5)
sleep 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)