This function creates a mip mapped version of the source image. The mip mapped version is 1/2 the original size and the source pixels are blended together during the scale. This tends to make the resulting image a better (subjective!) representation than a linear scale.
[pbcode]
Circle 128,128,128,true
getImage 1,0,0,256,256
Cls 255
Max=4
Dim MipMaps(Max)
Dim Scaled(Max)
MipMaps(1)=1
Scaled(1)=1
ThisIMage=1
For lp=2 to Max
; Make the mipmap from the Last image
ThisImage=CreateMipMap(ThisImage)
MipMaps(lp)=ThisImage
; make the scaled version (scaling from the original image)
Width =GetImageWidth(thisImage)
Height =GetImageHeight(thisImage)
ScaledIMage=getFreeimage()
CopyImage 1,ScaledIMage
Scaleimage ScaledImage,Width,height,1
Scaled(lp)=Scaledimage
next
; Draw the mip mapped + scaled versions of the images
Xpos=100
For lp=1 to Max
img=MipMaps(lp)
drawimage Img,Xpos,20,false
img=Scaled(lp)
drawimage Img,Xpos,300,false
Xpos=Xpos+getImageWIdth(img)+16
next
sync
waitkey
Function CreateMipMap(ThisImage)
oldSurface=getsurface()
if GetImageStatus(ThisImage)
W=GetImageWidth(ThisImage)
H=GetImageHeight(ThisImage)
w2=w/2
h2=h/2
if GetimageType(ThisImage)=1 then MipImage=NewImage(W2,h2)
if GetimageType(ThisImage)=2 then MipImage=NewFXImage(W2,h2)
if GetImageSTatus(MipIMage)
Dim Buffer(w,h)
RenderToImage Thisimage
lockbuffer
maskcolour=point(0,0)
For Ylp=0 to H-1
For Xlp=0 to W-1
Buffer(Xlp,ylp)=FastPOint(xlp,ylp)
next
next
unlockbuffer
rendertoimage MipImage
imagemaskcolour mipimage,maskcolour
For ylp=0 to (h and $fffe)-1 step 2
lockbuffer
ThisPixel=point(0,0)
Xpos=0
ylp2=ylp+1
For Xlp=0 to (W and $fffe)-1 step 2
Xlp2=xlp+1
C1=Buffer(Xlp,ylp)
C2=Buffer(Xlp2,ylp)
C3=Buffer(Xlp2,ylp2)
C4=Buffer(Xlp,ylp2)
r=(rgbr(c1)+rgbr(c2)+rgbr(c3)+rgbr(c4))/4
g=(rgbg(c1)+rgbg(c2)+rgbg(c3)+rgbg(c4))/4
b=(rgbb(c1)+rgbb(c2)+rgbb(c3)+rgbb(c4))/4
FastDot Xpos,Ypos,Rgb(r,g,b)
xpos=xpos+1
next
unlockbuffer
inc ypos
next
undim Buffer()
endif
endif
rendertoimage oldsurface
EndFunction MipImage
[/pbcode]
Here's a version that has alpha support and and uses the file dialog
[pbcode]
openscreen 1280,840,32,1
; Include the Dialogs library in this program
#Include "PBDialogs2"
; Title Of the Dialog
Filename$="Some Cool FIle.txt"
Filter$ ="(*.Images)|*.JPG;*.bmp;*.PNG;*tga" ; Mixture of image files
; Call the dialog
File$=OpenFileDialog("Load Image",Filename$,Filter$)
if fileexist(file$)
loadimage file$,1,8
Cls 255
Max=4
Dim MipMaps(Max)
Dim Scaled(Max)
MipMaps(1)=1
Scaled(1)=1
ThisIMage=1
For lp=2 to Max
; Make the mipmap from the Last image
ThisImage=CreateMipMap(ThisImage)
MipMaps(lp)=ThisImage
; make the scaled version (scaling from the original image)
Width =GetImageWidth(thisImage)
Height =GetImageHeight(thisImage)
ScaledIMage=getFreeimage()
CopyImage 1,ScaledIMage
Scaleimage ScaledImage,Width,height,1
Scaled(lp)=Scaledimage
next
; Draw the mip mapped + scaled versions of the images
Xpos=100
For lp=1 to Max
img=MipMaps(lp)
drawimage Img,Xpos,20,false
img=Scaled(lp)
drawimage Img,Xpos,300,false
Xpos=Xpos+getImageWIdth(img)+16
next
else
print "File Not Found"+File$
endif
sync
waitkey
end
Function CreateMipMap(ThisImage)
oldSurface=getsurface()
if GetImageStatus(ThisImage)
W=GetImageWidth(ThisImage)
H=GetImageHeight(ThisImage)
w2=w/2
h2=h/2
if GetimageType(ThisImage)=1 then MipImage=NewImage(W2,h2)
if GetimageType(ThisImage)=2 then MipImage=NewFXImage(W2,h2)
if GetImageSTatus(MipIMage)
Dim Buffer(w,h)
RenderToImage Thisimage
lockbuffer
maskcolour=point(0,0)
For Ylp=0 to H-1
For Xlp=0 to W-1
Buffer(Xlp,ylp)=FastPOint(xlp,ylp)
next
next
unlockbuffer
rendertoimage MipImage
imagemaskcolour mipimage,maskcolour
For ylp=0 to (h and $fffe)-1 step 2
lockbuffer
ThisPixel=point(0,0)
Xpos=0
ylp2=ylp+1
For Xlp=0 to (W and $fffe)-1 step 2
Xlp2=xlp+1
C1=Buffer(Xlp,ylp)
C2=Buffer(Xlp2,ylp)
C3=Buffer(Xlp2,ylp2)
C4=Buffer(Xlp,ylp2)
a=(rgba(c1)+rgba(c2)+rgba(c3)+rgba(c4))/4
r=(rgbr(c1)+rgbr(c2)+rgbr(c3)+rgbr(c4))/4
g=(rgbg(c1)+rgbg(c2)+rgbg(c3)+rgbg(c4))/4
b=(rgbb(c1)+rgbb(c2)+rgbb(c3)+rgbb(c4))/4
FastDot Xpos,Ypos,aRgb(a,r,g,b)
xpos=xpos+1
next
unlockbuffer
inc ypos
next
undim Buffer()
endif
endif
rendertoimage oldsurface
EndFunction MipImage
[/pbcode]