image scaler

Source-code only - please, don't post questions here.
dafhi
Posts: 1046
Joined: Jun 04, 2005 9:51

image scaler

Postby dafhi » Jun 04, 2017 21:48

2018 May 27 - new title
previous: "quality image downscaling"

Code: Select all

/' --- image scaler by dafhi - 2018 May 27 -------------------

  two original scalers in a wrap
 
 1. quick, if blit w or h > source w or h
 2. quality, incorporating every source pixel
 
'/

'#include "general.bas"
  '#include "anti-aliased-gfx-primitives/inc/base.bas"
    '#include "aaline.bas"
      '#include once "gmath.bas"
        '#include once "imagevars.bas"

/' ------- imagevars 2018 Jan 9 - by dafhi -------- '/

type myint as integer

type imagevars          '' 2018 Jan 16 - by dafhi
  '1. quick reference for ScreenInfo & ImageInfo
  '2. encapsulate standard metrics
  '3. convenient additional vars, subs and functions
  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 constructor   (as any ptr=0)
  declare sub           destroy
  declare               destructor
end type
Destructor.imagevars:  destroy
End Destructor
Sub imagevars.Destroy():  If ImageInfo(im) = 0 <> 0 Then ImageDestroy im: im = 0: endif:  End Sub
constructor.imagevars(img as any ptr):  if img<>0 then get_info img
end constructor
sub imagevars.get_info(im as any ptr)
  if im=0 then:  pixels=screenptr
    ScreenInfo w,h, bpp,, pitch, rate, driver_name:  bypp=bpp\8 '2018 Jan 9
  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


#Macro Alpha256(ret,back, fore, a256) '2017 Mar 26
  ret=((_
  (fore And &Hff00ff) * a256 + _
  (back And &Hff00ff) * (256-a256) + &H800080) And &Hff00ff00 Or (_
  (fore And &H00ff00) * a256 + _
  (back And &H00ff00) * (256-a256) + &H008000) And &H00ff0000) Shr 8
#EndMacro

Union UnionARGB
  As Ulong col:  Type: As UByte  B,G,R,A:  End Type
End Union
'
' ------------ imagevars.bas


#Ifndef floor
#Define floor(x) (((x)*2.0-0.5)shr 1) '' http://www.freebasic.net/forum/viewtopic.php?p=118633
#define ceil(x) (-((-(x)*2.0-0.5)shr 1))
  #EndIf
'
' ------------ gmath.bas




Type sng2D
    As Single                     x,y
End Type

type image_scaler extends imagevars
  declare function      resize(byref dest as image_scaler ptr=0, x as single=0, y as single=0, w as single=0, h as single=0) as integer
 private:
  declare sub           downscale_aascan(yDes as integer, alp as single)
  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)
   
  ' higher quality but with grid artifact if blit w,h > source
  declare sub           downscale(byref dest as image_scaler ptr=0, x as single=0, y as single=0, w as single=0, h as single=0)
  as imagevars ptr      pdes            '
  as long               yDes1D, ySrc1D  '
  as single             sx, x_scal      '
  as single             x_step, y_step
  As sng2D              ptA,ptB,ptC,ptD
  as single             sR(any), sG(any), sB(any), a(any)
  as myint              yDesT, yDesB
End Type
Sub image_scaler.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
    alpha_sum += aa_fractional
  #EndMacro
 
  #Macro BoundsCheckSource(aa_mul1, aa_mul2)
    If srcY >= 0 andalso srcX >= 0 Then
      If srcY < h andalso srcX < w Then
        LayerSource_Components( aa_mul1, aa_mul2 )
      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  xRight = xleft + wid_ - 1
  Dim As myint  yBot = ytop + hgt_ - 1
 
  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
      var alpha_sum = 0f
     
      Dim As UnionARGB ptr ptrSource = pixels
      ptrSource += srcY * pitchBy + srcX
      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
      dim as long al = 256 * alpha_sum
      Alpha256( pixDest[xDest].col, pixDest[xDest].col, rgb(sRed,sGrn,sBlu), al )
    Next
  Next
 
End Sub
sub image_scaler.downscale_aascan(yDes as integer, alp as single)
  if yDes < 0 or yDes > pdes->hm then exit sub
  #Macro SngAry()
    sR(i) += al*((src and &HFF0000)shr 16)
    sG(i) += al*((src and &HFF00)shr 8)
    sB(i) += al*(src and &HFF)
  #endmacro
  yDes1D = yDes * pdes->pitchBy
  dim as single al
  for xSrc as long = 0 to wm
    var xDesL = floor(sx):  sx += x_step
    var xDesR = floor(sx)
    var i = yDes1D + xDesL
    dim as ulong src = p32[ySrc1D + xSrc]
    if xDesL < xDesR then
      if xDesL >= 0 and xDesL < pdes->w then
        al = (xDesR - (sx-x_step)) * alp
        a(i) += al
        SngAry()
      endif
      if xDesR >= 0 and xDesR < pdes->w then
        al = (sx - xDesR) * alp
        i += 1:  a(i) += al
        SngAry()
      endif
    elseif xDesL >= 0 and xDesL < pdes->w then
      al = x_step * alp
      a(i) += al
      SngAry()
    endif
  next
end sub
sub image_scaler.downscale(byref dest as image_scaler ptr, x as single, y as single, _w as single, _h as single)'2017 Aug 17
 
  ' higher quality but with rendering artifacts if blit w,h > source w,h
 
  dim as imagevars  scr
  if dest = 0 then:  pdes = @scr: scr.get_info:  else:  pdes = dest:  endif
 
  var des_ub = pdes->pitch * pdes->h - 1
 
  if ubound(sR)<>des_ub then 'sRGBA size of dest
    redim sR(des_ub): redim sG(des_ub)
    redim sB(des_ub):  redim a(des_ub)
  endif
 
  if _w=0 then _w=pdes->w
  if _h=0 then _h=pdes->h
 
  var dest_x0 = floor(x):      if dest_x0 < 0 then dest_x0 = 0
  var dest_y0 = floor(y):      if dest_y0 < 0 then dest_y0 = 0
  var dest_x1 = floor(x + _w): if dest_x1 > pdes->wm then dest_x1 = pdes->wm
  var dest_y1 = floor(y + _h): if dest_y1 > pdes->hm then dest_y1 = pdes->hm
 
  'step 1:  reset
  for y as long = dest_y0 to dest_y1
    var ipitch = y*pdes->pitchBy
    for i as long = ipitch + dest_x0 to ipitch + dest_x1
      sr(i)=0:sg(i)=0:sb(i)=0:a(i)=0
    next
  next 
 
  x_step = _w / w
  y_step = _h / h
 
  'step 2:  accumulate
  for ySrc as long = 0 to hm
    yDesT = floor(y):  y += y_step
    yDesB = floor(y)
    ySrc1D = ySrc * pitchBy:  sx = x
    if yDesT < yDesB then
      downscale_aascan yDesT, yDesB - (y-y_step):  sx = x
      downscale_aascan yDesB, y - yDesB
    else 'equal
      downscale_aascan yDesT, y_step
    endif
  next:  y -= y_step * h
 
  'step 3:  convert
  for y as long = dest_y0 to dest_y1
    var ipitch = y*pdes->pitchBy
    for i as long = ipitch + dest_x0 to ipitch + dest_x1
      dim as ulong col = rgb( sR(i), sG(i), sB(i) )
      dim as long al = a(i)*256
      alpha256(pdes->p32[i], pdes->p32[i], col, al)
    next
  next

end sub
function image_scaler.resize(byref dest as image_scaler ptr=0, x as single=0, y as single=0, parm_w as single=0, parm_h as single=0) as integer
 
  if parm_w+.5 > w or parm_h+.5 > h then 'fast
   
    var int_x0 = int(x), int_x1=int(x+parm_w)
    var int_y0 = int(y), int_y1=int(y+parm_h)
   
    var int_w = int_x1 - int_x0 + 1
    var int_h = int_y1 - int_y0 + 1
   
    var scale_x = w/parm_w
    var scale_y = h/parm_h
   
    ptA.x = scale_x * (int_x0 - x)
    ptA.y = scale_y * (int_y0 - y)

    ptD.x = pta.x + int_w * scale_x
    ptD.y = ptA.y + int_h * scale_y
   
    ptC.x = ptA.x:  ptC.y = ptD.y
    ptB.x = ptD.x:  ptB.y = ptA.y
   
    skewRect_Render dest, int_x0, int_y0, int_w, int_h
    return 0
  else
    downscale dest,x,y,parm_w,parm_h
    return 1 'quality
  EndIf

End function
'
' ------------ image_scaler

type anglevars
  as single         a=rnd*6.28, i = 6.28*(.0015 * (.25 + rnd))
  as single         bas = 0.5, scale = .5
  declare operator  cast as single
end type
operator anglevars.cast as single
  a += i:  return bas + scale * sin(a)
end operator


sub main

  dim as image_scaler  buf, im

  screenres 640, 480, 32
  buf.get_info

  im.get_info imagecreate( 201,201)
  for i as long = 0 to im.wm step 10
    line im.im,(i,0)-(i,im.hm)
    line im.im,(0,i)-(im.wm,i)
  next

  var speed_fac = 1.0
  dim as anglevars  x,y,w,h
  x.bas = buf.wh/2:  x.scale = 150:  x.i*=speed_fac
  y.bas = buf.hh/2:  y.scale = 150:  y.i*=speed_fac
  w.bas = im.w*.95:  w.scale = im.wh/1:  w.i*=speed_fac
  h.bas = im.h*.95:  h.scale = im.hh/1:  h.i*=speed_fac

  dim as string kstr
  while kstr = ""
    screenlock
      cls
      put (0,0), im.im, pset
      var s="scaling:  "
      if im.resize( @buf, x, y, w, h )=1 then s+="quality" else s+="quick"
      ? s
    screenunlock
    sleep 15
    kstr = inkey
  wend

end sub

Main
dafhi
Posts: 1046
Joined: Jun 04, 2005 9:51

Re: image scaler

Postby dafhi » Jun 05, 2018 3:46

updated
dodicat
Posts: 5024
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: image scaler

Postby dodicat » Jun 07, 2018 18:38

Thanks dafhi.
Here is a little playaround.
Windows 32 bit compiler only.

Code: Select all

Screen 19,32,,8 Or 64
Color , Rgb(200,0,0)
Dim As Integer xres,yres
Screeninfo xres,yres

Declare Function MoveWindow Alias "MoveWindow"(As Any Ptr,As Integer,As Integer,As Integer,As Integer,As Integer) As Integer
Sub bird(i As Any Ptr)
    Dim As Integer xres,yres
    Imageinfo i,xres,yres
    Dim As Double PLOT_grade=1000
    Dim As Double temp1,temp2,x1,y1,x
    #macro sketch(_function,minx,maxx,miny,maxy)
    For x =minx To maxx Step (maxx-minx)/PLOT_GRADE
        x1=(xres)*(x-minx)/(maxx-minx)
        y1=(yres)*(_function-maxy)/(miny-maxy)
        If x=minx Then Pset i,(x1,y1),Rgb(0,0,10) Else Line i, -(x1,y1),Rgb(0,0,10)
        If Abs(x)<1e-3 Then
            temp1=x1:temp2=y1
        End If
    Next x
    Circle i,(temp1,temp2),50,Rgb(0,200,0),,,,f
    Circle i,(temp1-20,temp2-20),10,Rgb(200,200,200),,,,f
    Circle i,(temp1+20,temp2-20),10,Rgb(200,200,200),,,,f
   
    Circle i,(temp1-20-5*z,temp2-20),3,Rgb(00,00,200),,,,f
    Circle i,(temp1+20-5*z,temp2-20),3,Rgb(00,00,200),,,,f
   
    Circle i,(temp1,temp2),30,Rgb(0,0,0),4,5.5
    Circle i,(temp1,temp2-2),30,Rgb(0,0,0),4-k/3,5.5+k/3
    Circle i,(temp1,temp2),51,Rgb(0,0,10)
    #endmacro
   
    Static k As Integer=1
    Static z As Double
    Dim pi As Double=4*Atn(1)
    z=z+.02*k
    sketch (-Sin(z*x+z),-(pi),pi,-2,2)
    sketch (Sin(z*x-z),-(pi),pi,-2,2)
    Paint i,(.25*xres,.5*yres),Rgba(100,100,120,190),Rgb(0,0,10)
    Paint i,(.75*xres,.5*yres),Rgba(100,100,120,190),Rgb(0,0,10)
    If z>1.1 Then k=-k
    If z<-1.1 Then k=-k
    If z>2*pi Then z=0
End Sub

Dim As Integer I,frame=xres/20
Screencontrol(2,I)'getwindowhandle
Dim As Any Ptr Win = Cast(Any Ptr,I)

Dim As Any Ptr im,bdr=Imagecreate(xres,yres)
For n As Long=0 To frame
    Line bdr,(n,n)-(xres-n,yres-n),Rgb(255-n*3,255-n*3,255-n*3),b
Next

Dim As Single x=xres\4,y=yres\4,kx=4,ky =-4
if sizeof(integer)=8 then print "32 bit compiler only":sleep:end
Do
    im=Imagecreate(xres\3,yres\3,Rgb(0,100,255))
    bird(im)
    movewindow(win,50+x\2,50+y\2,xres-x,yres-y,1)
    x+=kx
    y+=ky
    If x<frame Or x>xres-(xres\3)-frame Then kx=-kx
    If y<frame Or y>yres-(yres\3)-frame Then ky=-ky
    Screenlock
    Cls
    Put(0,0),bdr,trans
    Put(x,y),im,trans
    Screenunlock
    Imagedestroy im
    Sleep 1,1
Loop Until Len(Inkey)
Sleep
Imagedestroy bdr

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 1 guest