Image Scaler (Resizer) with Pixel Blending

Source-code only - please, don't post questions here.
KristopherWindsor
Posts: 2428
Joined: Jul 19, 2006 19:17
Location: Sunnyvale, CA
Contact:

Image Scaler (Resizer) with Pixel Blending

Postby KristopherWindsor » Sep 26, 2007 4:55

The main problem with Multiput is, when resizing images, especially to downsize them, some pixels in the source image are never used in the target. I.e. if the image has a one-pixel wide black line in it, the line may not be present at all in the final image, because Multiput looked at the color of the pixels surrounding it, instead.

So I decided to write my own image scaler, and am pleased to have coded this without using anyone else's algorithms. :-) The program is too slow to be used in real-time, but, for example, it could be used in a game, before the level is loaded, to downsize a graphic, and then be rotated and displayed in real-time by Multiput. The end result will look better if the graphics are scaled with this program, especially if rotation is unnecessary, and Multiput can be avoided altogether. (But Multiput is still a great tool. :-))

This program uses pixel blending, so for example, if an image is scaled to 50%, each pixel in the downscaled image will have the average color of four pixels in the original image. The code can also upscale images, but it is not quite as good as Photoshop until I learn bi-cubic re-sampling. :-P

BTW, this is the first time I have used the FB namespace, the "->" syntax, and overloaded Subs. :-D

Image

Code: Select all

' Image Scaler! v1.0
' (C) 2007 i-TECH and Kristopher Windsor

#include "fbgfx.bi"
#define float double
#define cfloat cdbl

Sub image_scaler Overload (Byval target As fb.image Ptr, Byval x As Integer = 0, Byval y As Integer = 0, Byval source As fb.image Ptr, Byval scale As float)
  Dim As Integer dest_size_x, dest_size_y
  Dim As Integer dest_loop_x, dest_loop_y
  Dim As Integer srce_size_x, srce_size_y
  Dim As Integer srce_loop_x, srce_loop_y
  Dim As Integer srce_color
  Dim As float red, green, blue
  Dim As float x1, y1, x2, y2, overlap_factor, total_pixels
  Dim As float overlap_1, overlap_2, overlap_3, overlap_4, overlap_5, overlap_6 'temp variables to see how much of a certain source pixel overlaps a destination pixel
 
  srce_size_x = source -> Width
  srce_size_y = source -> height
  dest_size_x = srce_size_x * scale
  dest_size_y = srce_size_y * scale
 
  'loop for each destination pixel
  For dest_loop_x = 0 To dest_size_x - 1
    For dest_loop_y = 0 To dest_size_y - 1
      'find the source pixels under this destination pixel
      x1 = cfloat(dest_loop_x) / dest_size_x * srce_size_x - .5
      x2 = cfloat(dest_loop_x + 1) / dest_size_x * srce_size_x - .5
      y1 = cfloat(dest_loop_y) / dest_size_y * srce_size_y - .5
      y2 = cfloat(dest_loop_y + 1) / dest_size_y * srce_size_y - .5
     
      'loop through all of the source pixels under this destination pixel to get the average color
      red = 0: green = 0: blue = 0: total_pixels = 0
      For srce_loop_x = x1 To x2
        For srce_loop_y = y1 To y2
          'the following can be replaced with 'overlap_factor = 1,' but it will be slightly less accurate (especially in the last row and column)
          'overlaps 1, 2: location of destination pixel; 3, 4: part of source pixel under destination pixel; 5, 6: location of source pixel
          'x overlap factor
          overlap_1 = cfloat(dest_loop_x) / dest_size_x
          overlap_2 = cfloat(dest_loop_x + 1) / dest_size_x
          overlap_3 = cfloat(srce_loop_x) / srce_size_x
          overlap_4 = cfloat(srce_loop_x + 1) / srce_size_x
          overlap_5 = overlap_3
          overlap_6 = overlap_4
          If overlap_3 < overlap_1 Or overlap_3 > overlap_2 Then overlap_3 = Iif(Abs(overlap_3 - overlap_1) < Abs(overlap_3 - overlap_2), overlap_1, overlap_2)
          If overlap_4 < overlap_1 Or overlap_4 > overlap_2 Then overlap_4 = Iif(Abs(overlap_4 - overlap_1) < Abs(overlap_4 - overlap_2), overlap_1, overlap_2)
          overlap_factor = Abs((overlap_3 - overlap_4) / (overlap_5 - overlap_6))
          'y overlap factor
          overlap_1 = cfloat(dest_loop_y) / dest_size_y
          overlap_2 = cfloat(dest_loop_y + 1) / dest_size_y
          overlap_3 = cfloat(srce_loop_y) / srce_size_y
          overlap_4 = cfloat(srce_loop_y + 1) / srce_size_y
          overlap_5 = overlap_3
          overlap_6 = overlap_4
          If overlap_3 < overlap_1 Or overlap_3 > overlap_2 Then overlap_3 = Iif(Abs(overlap_3 - overlap_1) < Abs(overlap_3 - overlap_2), overlap_1, overlap_2)
          If overlap_4 < overlap_1 Or overlap_4 > overlap_2 Then overlap_4 = Iif(Abs(overlap_4 - overlap_1) < Abs(overlap_4 - overlap_2), overlap_1, overlap_2)
          overlap_factor *= Abs((overlap_3 - overlap_4) / (overlap_5 - overlap_6))
         
          'overlap_factor = 1
          If overlap_factor > 1E-12 Then
            total_pixels += overlap_factor 'if all of the source pixel is under the destination pixel, then a whole pixel is added
            srce_color = Point(srce_loop_x, srce_loop_y, source)
            red += ((srce_color And &H00FF0000) Shr 16) * overlap_factor
            green += ((srce_color And &H0000FF00) Shr 8) * overlap_factor
            blue += (srce_color And &H000000FF) * overlap_factor
          End If
        Next y
      Next x
      red /= total_pixels: green /= total_pixels: blue /= total_pixels
     
      'draw
      Pset target, (x + dest_loop_x, y + dest_loop_y), (256 Shl 24) Or (red Shl 16) Or (green Shl 8) Or blue
    Next dest_loop_y
  Next dest_loop_x
End Sub

Sub image_scaler Overload (Byval x As Integer = 0, Byval y As Integer = 0, Byval source As fb.image Ptr, Byval scale As float)
  image_scaler 0, x, y, source, scale
End Sub

Dim As Integer x, y
Dim Shared As fb.image Ptr picture

Screenres 800, 600, 32
Setmouse 256, 256, 0

picture = imagecreate(256, 256, &HFF00FF00)
Circle picture, (100, 100), 50, &HFF000000
Circle picture, (150, 150), 5, &HFFFFFF00
Line picture, (100, 0) - (100, 100), &HFF00FFFF
Pset picture, (8, 8), &HFF000000

Do
  If Getmouse(x, y) = 0 Then
    Screenlock
    Cls
    image_scaler 0, 0, picture, x / 256
    image_scaler x, y, picture, x / 512
    Screenunlock
  End If
  Sleep 50
Loop Until Inkey = Chr(27)
System
duke4e
Posts: 717
Joined: Dec 04, 2005 0:16
Location: Varazdin, Croatia, Europe
Contact:

Postby duke4e » Sep 26, 2007 13:42

here's bilinear rotozoom... the code isn't perfect, but in combination with some tutorial, this it can be customized to suit everybody's needs.

Code: Select all

#define GetR(_c) ((_c Shr 16) And &hFF)
#define GetG(_c) ((_c Shr  8) And &hFF)
#define GetB(_c) ((_c       ) And &hFF)

Const textureX = 512
Const textureY = 512
Const As Single pi = 3.1415926535897932384626433832795

Screenres textureX, textureY, 32

Dim img1 As Any Ptr = Imagecreate(textureX, textureY)
Bload "texture.bmp", img1

Dim Shared As Integer mytexture(textureX, textureY)
Dim Shared As Integer dest(textureX, textureY)

Put(0, 0), img1
For x As Integer = 0 To textureX - 1
    For y As Integer = 0 To textureY - 1
        mytexture(x, y) = Point(x, y)
    Next
Next
Imagedestroy(img1)

Function Min(a As Single, b As Single) As Single
    If a < b Then Return a Else Return b
End Function

Function Clamp(x As Integer) As Integer
    If x < 0 Then x = 0
    If x > 255 Then x = 255
    Return x
End Function


Sub Bilinear_RotoZoom(angle As Single, xscale As Single, yscale As Single)
   Dim As Single ang = -angle * (Pi / 180)
   Dim As Single cos_angle = Cos(ang)
   Dim As Single sin_angle = Sin(ang)
   
   Dim As Single minx = 0
   Dim As Single miny = 0
   Dim As Single maxx = textureX
   Dim As Single maxy = textureY
   
   Dim As Integer newWidth = Int(maxx - minx + 0.5)
   Dim As Integer newHeight= Int(maxy - miny + 0.5)
   Dim As Single ssx = ((maxx + minx) - (newWidth - 1)) / 2
   Dim As Single ssy = ((maxy + miny) - (newHeight - 1)) / 2
   
   Dim As Single newxcenteroffset = 0.5 * newWidth
   Dim As Single newycenteroffset = 0.5 * newHeight
   
    ssx -= 0.5 * textureX
    ssy -= 0.5 * textureY
   
   Dim As Single x, y
   Dim As Single origx, origy
   Dim As Integer destx, desty
   
   Dim As Single fX, fY
    Dim As Integer ifX, ifY, ifX1, ifY1
    Dim As Single ir1, ir2, ig1, ig2, ib1, ib2, dx, dy
    Dim As Integer r, g, b
   
   y = ssy
    For desty = 0 To newHeight - 1
        x = ssx
        For destx = 0 To newWidth - 1
            origx = (cos_angle * x + sin_angle * y) + newxcenteroffset
            origy = (cos_angle * y - sin_angle * x) + newycenteroffset
           
            If destx < textureX And destx >= 0 And desty < textureY And desty >= 0 Then
                fY = origy * yscale
                If fY > textureY Then fY = textureY
                If fY < 0 Then fY = 0
               
                ifY = Int(fY)
                ifY1 = Min(textureY - 1, ifY + 1)
               
                dy = fY - ifY
               
                fX = origx * xscale
                If fX > textureX Then fX = textureX
                If fX < 0 Then fX = 0
               
                ifX = Int(fX)
                ifX1 = Min(textureX - 1, ifX + 1)
               
                dx = fX - ifX
               
                ir1 = GetR(mytexture(ifX, ifY)) * (1 - dy) + GetR(mytexture(ifX, ifY1)) * dy
                ig1 = GetG(mytexture(ifX, ifY)) * (1 - dy) + GetG(mytexture(ifX, ifY1)) * dy
                ib1 = GetB(mytexture(ifX, ifY)) * (1 - dy) + GetB(mytexture(ifX, ifY1)) * dy
                ir2 = GetR(mytexture(ifX1, ifY)) * (1 - dy) + GetR(mytexture(ifX1, ifY1)) * dy
                ig2 = GetG(mytexture(ifX1, ifY)) * (1 - dy) + GetG(mytexture(ifX1, ifY1)) * dy
                ib2 = GetB(mytexture(ifX1, ifY)) * (1 - dy) + GetB(mytexture(ifX1, ifY1)) * dy
               
                r = Clamp(ir1 * (1 - dx) + ir2 * dx)
                g = Clamp(ig1 * (1 - dx) + ig2 * dx)
                b = Clamp(ib1 * (1 - dx) + ib2 * dx)
                dest(destx, desty) = Rgb(r, g, b)
            End If
            x += 1
        Next
        y += 1
    Next
End Sub

For i As Integer = 1 To 360 step 10
    screenlock
    Cls
    Bilinear_RotoZoom(i, i/180, i/180)
    For x As Integer = 0 To texturex - 1
        For y As Integer = 0 To texturey - 1
            Pset (x,y), dest(x,y)
            if inkey = chr(27) then end
        Next
    Next
    screenunlock
Next



and here's (also unfinished) bicubic scaler

Code: Select all

#define GetR(_c) ((_c Shr 16) And &hFF)
#define GetG(_c) ((_c Shr  8) And &hFF)
#define GetB(_c) ((_c       ) And &hFF)

Const textureX = 512
Const textureY = 512


Screenres textureX, textureY, 32

Dim img1 As Any Ptr = ImageCreate(textureX, textureY)
Bload "texture.bmp", img1

Dim Shared As Integer mytexture(textureX, textureY)
Dim Shared As Integer dest(textureX, textureY)

Put(0, 0), img1
For x As Integer = 0 To textureX - 1
    For y As Integer = 0 To textureY - 1
        mytexture(x, y) = Point(x, y)
    Next
Next
ImageDestroy(img1)




Function KernelBSpline(x As Single) As Single
   If x > 2 Then Return 0
   Dim As Single a, b, c, d
   Dim As Single xm1 = x - 1.0
   Dim As Single xp1 = x + 1.0
   Dim As Single xp2 = x + 2.0
   
   If xp2 <= 0 Then a = 0 Else a = xp2 * xp2 * xp2
   If xp1 <= 0 Then b = 0 Else b = xp1 * xp1 * xp1
   If x <= 0 Then c = 0 Else c = x * x * x
   If xm1 <= 0 Then d = 0 Else d = xm1 * xm1 * xm1
   
   Return 0.16666666666666666667 * (a - (4 * b) + (6 * c) - (4 * d))
End Function

Sub Bicubic(xscale As Single, yscale As Single)
   Dim As Single fX, fY
    Dim As Single f_x, f_y, a, b, rr, gg, bb, r1, r2
    Dim As Integer i_x, i_y, xx, yy
    Dim As Integer myr, myg, myb
   
    For y As Integer = 0 To textureY - 1
        f_y = y * yScale - 0.5
        i_y = Int(f_y)
        a   = f_y - Int(f_y)
        For x As Integer = 0 To textureX - 1
            f_x = x * xScale - 0.5
            i_x = Int(f_x)
            b   = f_x - Int(f_x)
           
            rr = 0
            gg = 0
            bb = 0
            For m As Integer = -1 To 2
                r1 = KernelBSpline(m - a)
                yy = i_y + m
                If yy < 0 Then yy = 0
                If yy >= textureY Then yy = textureY - 1
                For n As Integer = -1 To 2
                    r2 = r1 * KernelBSpline(b - n)
                    xx = i_x + n
                    If xx < 0 Then xx = 0
                    If xx >= textureX Then xx = textureX - 1
                   
                    myr = GetR(mytexture(xx, yy))
                    myg = GetG(mytexture(xx, yy))
                    myb = GetB(mytexture(xx, yy))
                   
                    rr += myr * r2
                    gg += myg * r2
                    bb += myb * r2
                Next
            Next
            dest(x, y) = Rgb(rr, gg, bb)
        Next
    Next
End Sub


Dim As Single t1, t2
t1 = Timer
Bicubic(0.3, 0.3)
t2 = Timer
For x As Integer = 0 To texturex - 1
    For y As Integer = 0 To texturey - 1
        Pset (x,y), dest(x,y)
        dest(x,y) = 0
    Next
Next
Print Using "#.###"; t2-t1
Sleep
Cls

t1 = Timer
Bicubic(3, 3)
t2 = Timer
For x As Integer = 0 To texturex - 1
    For y As Integer = 0 To texturey - 1
        Pset (x,y), dest(x,y)
        dest(x,y) = 0
    Next
Next
Print Using "#.###"; t2-t1
Sleep
notthecheatr
Posts: 1759
Joined: May 23, 2007 21:52
Location: Cut Bank, MT
Contact:

Postby notthecheatr » Sep 26, 2007 21:19

Cool! This may not be useful to me at the moment, but I like this type of thing. It's a pretty useful general-purpose thing to have, so if I ever need something like it I'll know how to do it.
D.J.Peters
Posts: 7191
Joined: May 28, 2005 3:28

Postby D.J.Peters » Sep 27, 2007 14:46

looks good
this is the result of MultiPut
(it's more for sprites (with rotation) as for fine line arts)

Joshy
Image

Code: Select all

dim as any ptr test=ImageCreate(256,256,0)
line   (  0,  0)-(255,255),rgb(&H00,&HFF,&H00),BF
pset   ( 10, 10)          ,rgb(&H00,&H00,&H00)
line   (100,100)-(100,  0),rgb(&H00,&HFF,&HFF)
circle (101,101),50       ,rgb(&H00,&H00,&H00)
circle (151,151),5        ,rgb(&HFF,&HFF,&H00)
get    (  0,  0)-(255,255),test
MultiPut(,255+64,255+64,test,0.49,0.49)
sleep
Lachie Dazdarian
Posts: 2230
Joined: May 31, 2005 9:59
Location: Croatia
Contact:

Postby Lachie Dazdarian » Sep 27, 2007 21:33

duke, your stuff is rather cool, but much slower than D.J.Peters' routine.

D.J.Peters, could you please post the latest version of Multiput. I had problems earlier using it with sprites featuring transparent background color.
duke4e
Posts: 717
Joined: Dec 04, 2005 0:16
Location: Varazdin, Croatia, Europe
Contact:

Postby duke4e » Sep 27, 2007 22:32

Yeah, bilinear and bicubic filters are slow. To get them realtime, use opengl :)
D.J.Peters
Posts: 7191
Joined: May 28, 2005 3:28

Postby D.J.Peters » Sep 28, 2007 5:21

Lachie Dazdarian wrote:...D.J.Peters, could you please post the latest version of Multiput. ...
http://www.freebasic.net/forum/viewtopic.php?t=2441&highlight=multiput
there is nothing new in MultiPut

Joshy
Pritchard
Posts: 5425
Joined: Sep 12, 2005 20:06
Location: Ohio, USA

Postby Pritchard » Oct 06, 2007 23:58

I thought this was pretty awesome.
KristopherWindsor
Posts: 2428
Joined: Jul 19, 2006 19:17
Location: Sunnyvale, CA
Contact:

Postby KristopherWindsor » Jul 09, 2008 23:42

Here's an updated version; the only change is that it uses pointers to replace Point() and Pset(), so it is slightly faster now.
If there are any bugs I will probably find them soon. :-D

Code: Select all

' Image Scaler! v1.1
' (C) 2008 Innova and Kristopher Windsor

#include "fbgfx.bi"
#define float double
#define cfloat Cdbl

Sub image_scaler Overload (Byval itarget As fb.image Ptr = 0, Byval x As Integer = 0, Byval y As Integer = 0, Byval isource As fb.image Ptr, Byval scale As float)
  Dim As Integer dest_size_x, dest_size_y, dest_realsize_x, dest_realsize_y
  Dim As Integer dest_loop_x, dest_loop_y
  Dim As Integer srce_size_x, srce_size_y
  Dim As Integer srce_loop_x, srce_loop_y
  Dim As Integer dest_pitch, srce_pitch
  Dim As Integer srce_color
  Dim As Integer dest_loop_x1, dest_loop_y1, dest_loop_x2, dest_loop_y2
  Dim As float red, green, blue
  Dim As float x1, y1, x2, y2, overlap_factor, total_pixels
  Dim As float overlap_1, overlap_2, overlap_3, overlap_4, overlap_5, overlap_6 'temp variables to see how much of a certain source pixel overlaps a destination pixel
  Dim As Uinteger Ptr dest_ptr, srce_ptr
 
  If isource = 0 Then
    Screeninfo(srce_size_x, srce_size_y,,, srce_pitch)
    srce_ptr = Screenptr
  Else
    srce_size_x = isource -> Width
    srce_size_y = isource -> height
    srce_pitch = isource -> pitch
    srce_ptr = cast(Uinteger Ptr, isource + 1)
  End If
  srce_pitch Shr= 2
 
  If itarget = 0 Then
    Screeninfo(dest_realsize_x, dest_realsize_y,,, dest_pitch)
    dest_ptr = Screenptr
  Else
    dest_realsize_x = itarget -> Width
    dest_realsize_y = itarget -> height
    dest_pitch = itarget -> pitch
    dest_ptr = cast(Uinteger Ptr, itarget + 1)
  End If
  dest_pitch Shr= 2
  dest_ptr += x + y * dest_pitch
 
  'real size was used for clipping; now use this for other things
  dest_size_x = srce_size_x * scale
  dest_size_y = srce_size_y * scale
 
  'clipping
  dest_loop_x1 = 0
  dest_loop_x2 = dest_size_x - 1
  If dest_loop_x1 + x < 0 Then dest_loop_x1 = -x
  If dest_loop_x1 + x > dest_realsize_x - 1 Then dest_loop_x1 = dest_realsize_x - x - 1
  If dest_loop_x2 + x < 0 Then dest_loop_x2 = -x
  If dest_loop_x2 + x > dest_realsize_x - 1 Then dest_loop_x2 = dest_realsize_x - x - 1
 
  dest_loop_y1 = 0
  dest_loop_y2 = dest_size_y - 1
  If dest_loop_y1 + y < 0 Then dest_loop_y1 = -y
  If dest_loop_y1 + y > dest_realsize_y - 1 Then dest_loop_y1 = dest_realsize_y - y - 1
  If dest_loop_y2 + y < 0 Then dest_loop_y2 = -y
  If dest_loop_y2 + y > dest_realsize_y - 1 Then dest_loop_y2 = dest_realsize_y - y - 1
 
  'loop for each destination pixel
  For dest_loop_x = dest_loop_x1 To dest_loop_x2
    For dest_loop_y = dest_loop_y1 To dest_loop_y2
      'find the source pixels under this destination pixel
      x1 = cfloat(dest_loop_x) / dest_size_x * srce_size_x - .5
      x2 = cfloat(dest_loop_x + 1) / dest_size_x * srce_size_x - .5
      y1 = cfloat(dest_loop_y) / dest_size_y * srce_size_y - .5
      y2 = cfloat(dest_loop_y + 1) / dest_size_y * srce_size_y - .5
     
      'loop through all of the source pixels under this destination pixel to get the average color
      red = 0: green = 0: blue = 0: total_pixels = 0
      For srce_loop_x = x1 To x2
        For srce_loop_y = y1 To y2
          'the following can be replaced with 'overlap_factor = 1,' but it will be slightly less accurate (especially in the last row and column)
          'overlaps 1, 2: location of destination pixel; 3, 4: part of source pixel under destination pixel; 5, 6: location of source pixel
          'x overlap factor
          overlap_1 = cfloat(dest_loop_x) / dest_size_x
          overlap_2 = cfloat(dest_loop_x + 1) / dest_size_x
          overlap_3 = cfloat(srce_loop_x) / srce_size_x
          overlap_4 = cfloat(srce_loop_x + 1) / srce_size_x
          overlap_5 = overlap_3
          overlap_6 = overlap_4
          If overlap_3 < overlap_1 Or overlap_3 > overlap_2 Then overlap_3 = Iif(Abs(overlap_3 - overlap_1) < Abs(overlap_3 - overlap_2), overlap_1, overlap_2)
          If overlap_4 < overlap_1 Or overlap_4 > overlap_2 Then overlap_4 = Iif(Abs(overlap_4 - overlap_1) < Abs(overlap_4 - overlap_2), overlap_1, overlap_2)
          overlap_factor = Abs((overlap_3 - overlap_4) / (overlap_5 - overlap_6))
          'y overlap factor
          overlap_1 = cfloat(dest_loop_y) / dest_size_y
          overlap_2 = cfloat(dest_loop_y + 1) / dest_size_y
          overlap_3 = cfloat(srce_loop_y) / srce_size_y
          overlap_4 = cfloat(srce_loop_y + 1) / srce_size_y
          overlap_5 = overlap_3
          overlap_6 = overlap_4
          If overlap_3 < overlap_1 Or overlap_3 > overlap_2 Then overlap_3 = Iif(Abs(overlap_3 - overlap_1) < Abs(overlap_3 - overlap_2), overlap_1, overlap_2)
          If overlap_4 < overlap_1 Or overlap_4 > overlap_2 Then overlap_4 = Iif(Abs(overlap_4 - overlap_1) < Abs(overlap_4 - overlap_2), overlap_1, overlap_2)
          overlap_factor *= Abs((overlap_3 - overlap_4) / (overlap_5 - overlap_6))
         
          'overlap_factor = 1
          If overlap_factor > 1E-6 Then
            total_pixels += overlap_factor 'if all of the source pixel is under the destination pixel, then a whole pixel is added
            'point()
            srce_color = *(srce_ptr + srce_loop_x + srce_loop_y * srce_pitch)
            red += ((srce_color And &H00FF0000) Shr 16) * overlap_factor
            green += ((srce_color And &H0000FF00) Shr 8) * overlap_factor
            blue += (srce_color And &H000000FF) * overlap_factor
          End If
        Next srce_loop_y
      Next srce_loop_x
      red /= total_pixels: green /= total_pixels: blue /= total_pixels
     
      'draw (pset())
      *(dest_ptr + dest_loop_x + dest_loop_y * dest_pitch) = (&HFF000000) Or (red Shl 16) Or (green Shl 8) Or blue
    Next dest_loop_y
  Next dest_loop_x
End Sub

Sub image_scaler Overload (Byval x As Integer = 0, Byval y As Integer = 0, Byval source As fb.image Ptr, Byval scale As float)
  image_scaler 0, x, y, source, scale
End Sub

Dim As Integer x, y
Dim Shared As fb.image Ptr picture

Screenres 800, 600, 32
Setmouse 256, 256, 0

picture = imagecreate(256, 256, &HFF00FF00)
Line picture, (0, 0) - (255, 255), &HFFFF0000, B
Circle picture, (100, 100), 50, &HFF000000
Circle picture, (150, 150), 5, &HFFFFFF00
Line picture, (100, 0) - (100, 100), &HFF00FFFF
Pset picture, (8, 8), &HFF000000

Do
  If Getmouse(x, y) = 0 Then
    Screenlock
    Cls
    image_scaler 0, 0, picture, x / 256
    image_scaler x, y, picture, x / 512
    Screenunlock
  End If
  Sleep 10
Loop Until Inkey = Chr(27)
System
 


Edit: here is a version that supports "trans" blending:

Code: Select all

' Image Scaler! v1.1b
' (C) 2008 Innova and Kristopher Windsor

#define float double
#define cfloat Cdbl

Sub image_scaler Overload (Byval itarget As fb.image Ptr = 0, Byval x As Integer = 0, Byval y As Integer = 0, Byval isource As fb.image Ptr, Byval scale As float)
  Dim As Integer dest_size_x, dest_size_y, dest_realsize_x, dest_realsize_y
  Dim As Integer dest_loop_x, dest_loop_y
  Dim As Integer srce_size_x, srce_size_y
  Dim As Integer srce_loop_x, srce_loop_y
  Dim As Integer dest_pitch, srce_pitch
  Dim As Integer srce_color
  Dim As Integer dest_loop_x1, dest_loop_y1, dest_loop_x2, dest_loop_y2
  Dim As float red, green, blue
  Dim As float x1, y1, x2, y2, overlap_factor, total_pixels
  Dim As float overlap_1, overlap_2, overlap_3, overlap_4, overlap_5, overlap_6 'temp variables to see how much of a certain source pixel overlaps a destination pixel
  Dim As Uinteger Ptr dest_ptr, srce_ptr
 
  If isource = 0 Then
    Screeninfo(srce_size_x, srce_size_y,,, srce_pitch)
    srce_ptr = Screenptr
  Else
    srce_size_x = isource -> Width
    srce_size_y = isource -> height
    srce_pitch = isource -> pitch
    srce_ptr = cast(Uinteger Ptr, isource + 1)
  End If
  srce_pitch Shr= 2
 
  If itarget = 0 Then
    Screeninfo(dest_realsize_x, dest_realsize_y,,, dest_pitch)
    dest_ptr = Screenptr
  Else
    dest_realsize_x = itarget -> Width
    dest_realsize_y = itarget -> height
    dest_pitch = itarget -> pitch
    dest_ptr = cast(Uinteger Ptr, itarget + 1)
  End If
  dest_pitch Shr= 2
  dest_ptr += x + y * dest_pitch
 
  'real size was used for clipping; now use this for other things
  dest_size_x = srce_size_x * scale
  dest_size_y = srce_size_y * scale
 
  'clipping
  dest_loop_x1 = 0
  dest_loop_x2 = dest_size_x - 1
  If dest_loop_x1 + x < 0 Then dest_loop_x1 = -x
  If dest_loop_x1 + x > dest_realsize_x - 1 Then dest_loop_x1 = dest_realsize_x - x - 1
  If dest_loop_x2 + x < 0 Then dest_loop_x2 = -x
  If dest_loop_x2 + x > dest_realsize_x - 1 Then dest_loop_x2 = dest_realsize_x - x - 1
 
  dest_loop_y1 = 0
  dest_loop_y2 = dest_size_y - 1
  If dest_loop_y1 + y < 0 Then dest_loop_y1 = -y
  If dest_loop_y1 + y > dest_realsize_y - 1 Then dest_loop_y1 = dest_realsize_y - y - 1
  If dest_loop_y2 + y < 0 Then dest_loop_y2 = -y
  If dest_loop_y2 + y > dest_realsize_y - 1 Then dest_loop_y2 = dest_realsize_y - y - 1
 
  'loop for each destination pixel
  For dest_loop_x = dest_loop_x1 To dest_loop_x2
    For dest_loop_y = dest_loop_y1 To dest_loop_y2
      'find the source pixels under this destination pixel
      x1 = cfloat(dest_loop_x) / dest_size_x * srce_size_x - .5
      x2 = cfloat(dest_loop_x + 1) / dest_size_x * srce_size_x - .5
      y1 = cfloat(dest_loop_y) / dest_size_y * srce_size_y - .5
      y2 = cfloat(dest_loop_y + 1) / dest_size_y * srce_size_y - .5
     
      'loop through all of the source pixels under this destination pixel to get the average color
      red = 0: green = 0: blue = 0: total_pixels = 0
      For srce_loop_x = x1 To x2
        For srce_loop_y = y1 To y2
          'the following can be replaced with 'overlap_factor = 1,' but it will be slightly less accurate (especially in the last row and column)
          'overlaps 1, 2: location of destination pixel; 3, 4: part of source pixel under destination pixel; 5, 6: location of source pixel
          'x overlap factor
          overlap_1 = cfloat(dest_loop_x) / dest_size_x
          overlap_2 = cfloat(dest_loop_x + 1) / dest_size_x
          overlap_3 = cfloat(srce_loop_x) / srce_size_x
          overlap_4 = cfloat(srce_loop_x + 1) / srce_size_x
          overlap_5 = overlap_3
          overlap_6 = overlap_4
          If overlap_3 < overlap_1 Or overlap_3 > overlap_2 Then overlap_3 = Iif(Abs(overlap_3 - overlap_1) < Abs(overlap_3 - overlap_2), overlap_1, overlap_2)
          If overlap_4 < overlap_1 Or overlap_4 > overlap_2 Then overlap_4 = Iif(Abs(overlap_4 - overlap_1) < Abs(overlap_4 - overlap_2), overlap_1, overlap_2)
          overlap_factor = Abs((overlap_3 - overlap_4) / (overlap_5 - overlap_6))
          'y overlap factor
          overlap_1 = cfloat(dest_loop_y) / dest_size_y
          overlap_2 = cfloat(dest_loop_y + 1) / dest_size_y
          overlap_3 = cfloat(srce_loop_y) / srce_size_y
          overlap_4 = cfloat(srce_loop_y + 1) / srce_size_y
          overlap_5 = overlap_3
          overlap_6 = overlap_4
          If overlap_3 < overlap_1 Or overlap_3 > overlap_2 Then overlap_3 = Iif(Abs(overlap_3 - overlap_1) < Abs(overlap_3 - overlap_2), overlap_1, overlap_2)
          If overlap_4 < overlap_1 Or overlap_4 > overlap_2 Then overlap_4 = Iif(Abs(overlap_4 - overlap_1) < Abs(overlap_4 - overlap_2), overlap_1, overlap_2)
          overlap_factor *= Abs((overlap_3 - overlap_4) / (overlap_5 - overlap_6))
         
          'overlap_factor = 1
          If overlap_factor > 1E-10 Then
            'point()
            srce_color = *(srce_ptr + srce_loop_x + srce_loop_y * srce_pitch)
            if srce_color <> &HFFFF00FF then
              total_pixels += overlap_factor 'if all of the source pixel is under the destination pixel, then a whole pixel is added
              red += ((srce_color And &H00FF0000) Shr 16) * overlap_factor
              green += ((srce_color And &H0000FF00) Shr 8) * overlap_factor
              blue += (srce_color And &H000000FF) * overlap_factor
            end if
          End If
        Next srce_loop_y
      Next srce_loop_x
      red /= total_pixels: green /= total_pixels: blue /= total_pixels
     
      'draw (pset())
      If total_pixels > 0 Then
        *(dest_ptr + dest_loop_x + dest_loop_y * dest_pitch) = (&HFF000000) Or (red Shl 16) Or (green Shl 8) Or blue
      End If
    Next dest_loop_y
  Next dest_loop_x
End Sub

Sub image_scaler Overload (Byval x As Integer = 0, Byval y As Integer = 0, Byval source As fb.image Ptr, Byval scale As float)
  image_scaler 0, x, y, source, scale
End Sub
Last edited by KristopherWindsor on Jul 10, 2008 1:50, edited 1 time in total.
counting_pine
Site Admin
Posts: 5811
Joined: Jul 05, 2005 17:32
Location: Manchester, Lancs

Postby counting_pine » Jul 10, 2008 0:38

I don't know if you'd count them as bugs, but it would be possible to make it a little safer, e.g. aborting if the screen/image isn't 32-bit, or if it detects null ptrs.
You could also add support for old-style headers (ImageInfo() will make this easier), or at least abort if it detects an old-style header.
KristopherWindsor
Posts: 2428
Joined: Jul 19, 2006 19:17
Location: Sunnyvale, CA
Contact:

Postby KristopherWindsor » Jul 10, 2008 1:48

counting_pine wrote:I don't know if you'd count them as bugs, but it would be possible to make it a little safer, e.g. aborting if the screen/image isn't 32-bit, or if it detects null ptrs.
You could also add support for old-style headers (ImageInfo() will make this easier), or at least abort if it detects an old-style header.


I figured I would get feedback like this. ;-)
But there is no reason (for me :-P) to do real-time checks to detect code usage bugs; if it detects the wrong screen mode, it either means the developer has no idea what he is doing, or he didn't check to make sure the screen was initialized.
IE. in my current project I am using this, Multiput(), and ABFont, all of which use pointers like this. If each one had to check to make sure the screen is initialized, it would bloat my project. ;-)

BTW, when can we declare the old-style header dead? If people have to upgrade from v.15 to use my code I don't think it's a problem.
Also you probably can't even use this with -lang QB because of the use of overload and such. :-)
counting_pine
Site Admin
Posts: 5811
Joined: Jul 05, 2005 17:32
Location: Manchester, Lancs

Postby counting_pine » Jul 10, 2008 15:58

The old-style header is part of FB and isn't going to be retired. It's used in lang qb and lang fblite, and both forms are supported in FB, whatever dialect you use. That's why we decided to create a function to let you get the image information without having to worry about the header type.

Funnily enough, I think it's just the fb.image ptr param that's keeping the code from being lang fblite compatible. When ImageInfo comes out in the next release, you won't need the fb.image struct.

Ultimately, it's your decision whether you want to do some checks for null-pointers and bit depths, but they only take up a couple of lines. If someone was badly using code I'd written, I'd rather it crashed in their portion of the code than mine.
dpixel
Posts: 74
Joined: Aug 13, 2008 11:34
Location: US

Postby dpixel » Dec 08, 2008 22:15

KristopherWindsor This is really cool.

Is there a way of having this work in 8 bit?
KristopherWindsor
Posts: 2428
Joined: Jul 19, 2006 19:17
Location: Sunnyvale, CA
Contact:

Postby KristopherWindsor » Dec 08, 2008 23:01

dpixel wrote:KristopherWindsor This is really cool.

Is there a way of having this work in 8 bit?


I don't think so. :-/
IE how do you blend color 15 (60% weight) with color 16 (40% weight)?
Color 15 is white, and I don't know what color 16 is, so the best approximation would be some color larger than 16, but there is no way to mathematically calculate it.
dpixel
Posts: 74
Joined: Aug 13, 2008 11:34
Location: US

Postby dpixel » Dec 08, 2008 23:26

Ok. I see. That makes sense where the colors are blended when you shrink an image. I didn't even think of that.

Works great in 32 bit depth though. Nice and smooth and accurate :)

Return to “Tips and Tricks”

Who is online

Users browsing this forum: dafhi and 2 guests