Code: Select all
type imagevars '2016 Dec 18 - by dafhi
' 1. quick reference for ScreenInfo & ImageInfo
' 2. encapsulate standard metrics
' 3. additional-use vars
as any ptr im, pixels
as integer w,h,bpp,bypp,pitch,num_pages,flags,rate
as string driver_name
as ulong ptr p32
declare constructor(w as integer=0, h as integer=0, col as ulong=&HFF000000)
Declare Sub screen_init(wid As integer=-1, hgt As integer=-1, bpp as UInteger=32, numPages as integer=1, Flags as integer=0)
declare sub create(w as integer=0, h as integer=0, col as ulong=&HFF000000)
declare sub fill_info(im as any ptr=0)
declare sub checkers(pColor As ULong=RGBA(145,145,145,255), size As UInteger = 12)
declare sub cls(col as ulong=0)
as boolean is_screen '
as integer pitchBy, wm, hm, ub '
as single midx,midy, midxm, midym, diagonal, diagonalm
declare destructor
private:
declare sub destroy
declare sub release
as any ptr hRelease
end type
constructor imagevars(w as integer, h as integer, col as ulong) ' 2016 Aug 30
if w<1 or h<1 then exit constructor
if screenptr = 0 then screen_init w,h else create w,h
End Constructor
Destructor.imagevars
release
End Destructor
Sub imagevars.Destroy(): If im <> 0 Then ImageDestroy im: im = 0: endif: End Sub
sub imagevars.release '2016 Aug 30
w=0: h=0: bpp=0: bypp=0: im=0: pixels=0
If ImageInfo(hRelease) = 0 Then ImageDestroy hRelease: hRelease = 0
End Sub
sub imagevars.fill_info(im as any ptr) '2016 Nov 23
release
if im=0 then
ScreenInfo w,h, bpp, bypp, pitch, rate, driver_name: pixels=screenptr
is_screen = -1: im=0
elseif Imageinfo(im)=0 then
ImageInfo im, w, h, bypp, pitch, pixels: bpp = bypp * 8
this.im = im: is_screen = 0
endif: hRelease = im: p32=pixels
if bypp<>0 then pitchBy=pitch\bypp
wm=w-1: midx=w/2: midxm = wm/2
hm=h-1: midy=h/2: midym = hm/2: ub=w*h-1
diagonal=sqr(w*w+h*h): diagonalm=sqr(wm*wm+hm*hm)
end sub
sub imagevars.create(w as integer, h as integer, col as ulong)
fill_info
if bypp = 0 then exit sub
release: fill_info imagecreate(w,h,col)
End Sub
Sub imagevars.screen_init(w As integer, h As integer, _bpp as UInteger, _numpages as integer, _flags as integer)
var scale = 1
if w<1 or h<1 then scale=.8: ScreenInfo w,h
Destroy
ScreenRes w*scale,h*scale,_bpp,num_pages,flags: fill_info
num_pages=_numpages: flags=_flags
if num_pages > 1 then screenset 0,1
End sub
Sub imagevars.checkers(pColor As ULong, size As UInteger)
Dim As UInteger SizeDouble=size*2,SizeM=size-1
For Y as integer = 0 To hm Step size
For X as integer = -size * ((Y/SizeDouble)=Int(Y/SizeDouble)) To wm Step SizeDouble
Line im,(X,Y)-(X+SizeM,Y+SizeM),pColor,BF
Next
Next
End Sub
sub imagevars.cls(col as ulong)
dim as ulong ptr pEnd = p32+w*h-1: if bpp<>32 then exit sub
for p as ulong ptr = p32 to pend'32[w*h-1]
*p=col: Next
End Sub
#Macro Alpha256(ret,back, fore, am, a256)
ret=((_
(fore And &Hff00ff) * a256 + _
(back And &Hff00ff) * am + &H800080) And &Hff00ff00 Or (_
(fore And &H00ff00) * a256 + _
(back And &H00ff00) * am + &H008000) And &H00ff0000) Shr 8
#EndMacro
#ifndef pi
const TwoPi = 8*atn(1)
const Pi = 4*atn(1)
const piBy2 = 2*atn(1)
#endif
/' -- Anti-aliased lines - 2016 Aug 6 - by dafhi
' - usage -----------------------
dim as imagevars buf
buf.screen_init 800,600
dim as AaLine aa
aa.render_target buf
screenlock
buf.cls rgb(180,175,160)
aa.wid = 50
aa.draw 100,100,400,300, rgb(255,255,255)
screenunlock: sleep
' --------------------------------
I will be updating this project as time permits.
http://www.freebasic.net/forum/viewtopic.php?f=8&t=20719
'/
Type ScanIntercepts
as double ab,cd,bc,da
End Type
type AaLine
As single x0,y0,x1,y1,wid=1,alpha=1,endcap
as ulong col=&HFFFFFFFF
declare sub render_target(byref buf as imagevars)
declare sub draw(x0 as single=0, y0 as single=0, x1 as single=0, y1 as single=0, col as ulong=&HFFFFFFFF)
declare sub draw_by_vec(cenx as single=0,ceny as single=0, len as single=8,angle as single=0,col as ulong=&HFFFFFFFF)
declare sub drawme
as imagevars ptr im
private:
declare sub calc
as single sx0,sy0,sx1,sy1,ax,bx,cx,dx,ay,by,cy,dy
As single ayi,byi,cyi,dyi
As single dxL,bxR,axL,axR,cxL,cxR
as ulong ptr cBL,cBR,cTL,cTR 'window pixels: bottom-left, ..
as integer w,wm,hm,pitchx,pitchy,wmprev,hmprev
as single halfdx,halfdy, abslope_small, abslope_large
as single slen,swid, sdx,sdy, angle, scosa,ssina, cenx,ceny
As Single lenBy2, smallBy2,largeBy2
As single da0,da1,ab0,ab1,bc0,bc1,cd0,cd1
as single cenabx, cenaby, cencdx, cencdy
as integer yflipped, xyflipped
as ScanIntercepts sc0x, sc1x, sc0y, sc1y
as single a(Any), _alpha
declare sub handle_infinity
declare sub re_center
declare sub init
declare sub xyflip
declare sub yflip
declare sub octant
declare sub corners
Declare function int_lo(in As Single,clip As Single) As single
Declare function int_hi(in As Single,clip As Single) As Single
Declare Function xbound(x As Single) As Integer
Declare Function ybound(yLo As single,yHi As single,y As single) As Integer
declare sub scanwrite(xL0 As integer, xR1 as integer, y As integer)
Declare Function areasubt(ceptL As Single,ceptR As Single,edgeLo As Single) As Single
Declare Sub subt_ab(xL As single, xR As single,y As Integer)
Declare Sub subt_cd(xL As single, xR As single,y As Integer)
Declare Sub subt_da(x0 As single, x1 As single)
Declare Sub subt_bc(x0 As single, x1 As single)
Declare Function area_oversubtracted(vx As Single,vy As Single,ix As integer,iy As Integer) As Single
declare sub scanlines_adb(y0 as integer, y1 as single)
declare sub scanlines_cdb(y0 as integer, y1 as integer)
declare sub scanlines_abcd(y0 as integer, y1 as single)
declare sub scanlines_db(y0 as integer, y1 as single)
End Type
Sub AaLine.render_target(byref p as imagevars)
im = @p
end sub
sub AaLine.init
wm=im->wm: hm=im->hm
if wm<>wmprev or hm<>hmprev then
dim as integer ubmax = wm: if hm > ubmax then ubmax = hm
if ubmax > ubound(a) then ReDim a(ubmax)
wmprev=wm: hmprev=hm
end If
pitchx=1: pitchy=im->pitchBy
cBL=im->pixels: cTL=cBL+hm*pitchy
cBR=CBL+wm: cTR=cTL+wm: yflipped=0: xyflipped=0: _alpha=256*alpha
End sub
Sub AaLine.yflip
pitchy=-pitchy: yflipped=-1
swap cBL,cTL: swap cBR,cTR
ceny=hm+1-ceny: ssina=-ssina
end sub
sub AaLine.xyflip
swap cTL,cBR: xyflipped = -1
swap wm,hm: swap pitchx,pitchy
swap cenx,ceny: swap scosa,ssina
end sub
sub AaLine.re_center
lenBy2=slen/2
scosa=cos(angle)*lenBy2: ssina=sin(angle)*lenBy2
var dx0=im->midx-x0, dy0=im->midy-y0
var dx1=im->midx-x1, dy1=im->midy-y1
if dx0*dx0+dy0*dy0 < dx1*dx1+dy1*dy1 then 'point 0 closest to center
cenx=x0+scosa
ceny=y0+ssina
else
cenx=x1-scosa
ceny=y1-ssina
endif
end sub
sub AaLine.handle_infinity
sdx=x1-x0: sdy=y1-y0
slen=sqr(sdx*sdx+sdy*sdy)
if slen>1e9 then: slen=1e9
const sincos=1e9*sqr(1/2)
sdx=sincos*sgn(sdx)
sdy=sincos*sgn(sdy)
endif
if sdx=0 then
if sdy<0 then: angle= -pi/2
else: angle=pi/2: endif
else: angle=atn(sdy/sdx): if sdx<0 then angle+=pi
endif
re_center
swid=wid
if swid>1e9 then swid=1e9
slen+=endcap*swid
if slen < wid then
angle+=pi/2: swap swid,slen
end if: lenBy2=slen/2
'' temp fix for fbc
if angle=0 or abs(angle-pi)<0.00001 then angle += 0.0001
scosa=cos(angle)*lenBy2: ssina=sin(angle)*lenBy2
End sub
Sub AaLine.octant
if scosa<0 then scosa=-scosa: ssina=-ssina
if ssina<0 then yflip
if ssina>scosa then xyflip
w=wm+1
x0=cenx-scosa: x1=cenx+scosa
y0=ceny-ssina: y1=ceny+ssina
End sub
sub AaLine.corners
abslope_small=ssina/scosa: smallBy2=abslope_small/2
abslope_large=scosa/ssina: largeBy2=abslope_large/2
dim as single widByLen = swid/slen
dim as single hdxwid = ssina*widByLen, hdywid = scosa*widByLen
ax=x0+hdxwid: bx=x1+hdxwid: cx=x1-hdxwid: dx=x0-hdxwid
ay=y0-hdywid: by=y1-hdywid: cy=y1+hdywid: dy=y0+hdywid
ayi=Int(ay): byi=Int(by): cyi=Int(cy): dyi=Int(dy)
dxL=Int(dx): axL=Int(ax): axR=Int(ax)
bxR=Int(bx): cxL=Int(cx): cxR=Int(cx)
If dxL<0 Then: dxL=0: EndIf: If bxR>wm then: bxR=wm: endif
If axL<0 Then: axL=0: EndIf: If axR>wm Then: axR=wm: EndIf
If cxL<0 Then: cxL=0: EndIf: If cxR>wm Then: cxR=wm: EndIf
End Sub
Function AaLine.xbound(x As Single) As Integer
return x>=0 And x<w
End Function
Function AaLine.ybound(yLo As single,yHi As single,y As single) As Integer
return y>=yLo And y<= yHi
End Function
Function AaLine.areasubt(ceptL As Single,ceptR As Single,edgeL As Single) As Single
Dim As Single len_tri
If ceptL<edgeL Then ' ceptL
len_tri=ceptR-edgeL ' -+-----+
Return len_tri*len_tri*largeBy2 ' \####|
Else: Dim As Integer edgep=edgeL+1 ' \###|
If ceptR<edgep Then ' \##|
Return ceptR-edgeL-smallBy2 ' -----+-+
Else ' ceptR
len_tri=edgep-ceptL
Return 1-len_tri*len_tri*largeby2: EndIf
EndIf
End Function
Sub AaLine.subt_ab(x0 As single, x1 As single,y As integer)
sc1y.ab=cenaby+(x0-cenabx)*abslope_small
For x As Single=x0 To x1
sc0y.ab=sc1y.ab
sc1y.ab+=abslope_small
a(x)-=areasubt(sc0y.ab,sc1y.ab,y)
Next
end Sub
Sub AaLine.subt_cd(x0 As single, x1 As single,y As Integer)
sc1y.cd=cencdy+(x0-cencdx)*abslope_small
For x As Single=x0 To x1
sc0y.cd=sc1y.cd
sc1y.cd+=abslope_small
a(x)-=1-areasubt(sc0y.cd,sc1y.cd,y)
Next
end sub
sub AaLine.subt_da(x0 As single, x1 As single)
For x As Integer=x0 To x1
a(x)-=areasubt(sc1x.da,sc0x.da,x)
Next
end sub
Sub AaLine.subt_bc(x0 As single, x1 As single)
For x As single=x0 To x1
a(x)-=1-areasubt(sc1x.bc,sc0x.bc,x)
Next
End Sub
Function AaLine.area_oversubtracted(vx As Single,vy As Single,ix As integer,iy As Integer) As single
vx=Abs(vx-ix)
vy=Abs(vy-iy)
var ceptYleft=vy-vx*abslope_small
Dim As Single areaL
' area "low and left" of vertex
If ceptYleft<0 Then 'triangle
areaL=vy*vy*largeBy2
Else 'trapezoid
areaL=vx*(ceptYleft+vy)/2
End If
' area "low and right" of vertex
Var ceptXBottom=vx+vy*abslope_small
Var ixp=ix+1
If ceptXBottom<=1 Then 'triangle
Return areaL + vy*vy*smallBy2
Else 'trapezoid
Var vx1=1-vx
Return areaL+vx1*(vy-vx1*largeBy2)
EndIf
End Function
Sub AaLine.scanwrite(xL0 As integer, xR1 as integer, y As integer)
dim as ulong ptr p=@cBL[xL0*pitchx+y*pitchY]
for x as integer=xL0 to xR1
dim as ulong a256 = _alpha * a(x)
*p=((_
(col And &Hff00ff) * a256 + _
(*p And &Hff00ff) * (256-a256) + &H800080) And &Hff00ff00 Or (_
(col And &H00ff00) * a256 + _
(*p And &H00ff00) * (256-a256) + &H008000) And &H00ff0000) Shr 8
p+=pitchx
next
End Sub
Function AaLine.int_lo(in As Single,clip As Single) As Single
If in<clip Then: Return Int(clip): Else: Return Int(in): EndIf
End Function
Function AaLine.int_hi(in As Single,clip As Single) As Single
If in>clip Then: Return Int(clip): Else: Return Int(in): EndIf
End Function
sub AaLine.scanlines_abcd(y0 as integer, y1 as single)
if y0<0 then y0=0
if y1>hm then y1=hm
sc0x.cd=sc1x.cd: sc1x.cd=cencdx+(y0-cencdy)*abslope_large
sc0x.bc=sc1x.bc: sc1x.bc=bx-(y0-by)*abslope_small
for y As Integer=y0 to y1
sc0x=sc1x
sc1x.ab+=abslope_large
sc1x.cd+=abslope_large
sc1x.da-=abslope_small
sc1x.bc-=abslope_small
Dim As Integer inda=ybound(ayi,dyi,y)
Dim As Integer inab=ybound(ayi,byi,y)
Dim As Integer incd=ybound(dyi,cyi,y)
Dim As Integer inbc=ybound(byi,cyi,y)
Dim As single xL1=-1,xL0=wm+1
If inda Then
da0=int_lo(sc1x.da,dxL): If da0<xL0 Then xL0=da0
da1=int_hi(sc0x.da,axR): If da1>xL1 Then xL1=da1
EndIf
If incd Then
cd0=int_lo(sc0x.cd,dxL): If cd0<xL0 Then xL0=cd0
cd1=int_hi(sc1x.cd,cxR): If cd1>xL1 Then xL1=cd1
EndIf
Dim As single xR1=-1,xR0=wm+1
If inab Then
ab0=int_lo(sc0x.ab,axL): If ab0<xR0 Then xR0=ab0
ab1=int_hi(sc1x.ab,bxR): If ab1>xR1 Then xR1=ab1
EndIf
If inbc Then
bc0=int_lo(sc1x.bc,cxL): If bc0<xR0 Then xR0=bc0
bc1=int_hi(sc0x.bc,bxR): If bc1>xR1 Then xR1=bc1
EndIf
For x as integer=xL0 to xR1
a(x)=1
Next
If inda Then subt_da da0,da1
If inab Then subt_ab ab0,ab1,y
If inbc Then subt_bc bc0,bc1
If incd Then subt_cd cd0,cd1,y
If y=ayi And xbound(ax) Then
a(axL)+=area_oversubtracted(ax,ay,axL,ayi)
EndIf
If y=byi And xbound(bx) Then
a(bxR)+=area_oversubtracted(by,bx,byi,bxR+1)
EndIf
If y=cyi And xbound(cx) Then
a(cxR)+=area_oversubtracted(cx,cy,cxR+1,cyi+1)
EndIf
If y=dyi And xbound(dx) Then
a(dxL)+=area_oversubtracted(dy,dx,dyi+1,dxL)
EndIf
scanwrite xL0,xR1,y
next
end sub
sub AaLine.scanlines_adb(y0 as integer, y1 as single)
if y0<0 then y0=0
if y1>hm then y1=hm
if ax < w-cx then 'bc closest
cenabx=bx: cenaby=by
cencdx=cx: cencdy=cy
else
cenabx=ax: cenaby=ay
cencdx=dx: cencdy=dy
end if
sc1x.da=ax-(y0-ay)*abslope_small
sc1x.ab=cenabx+(y0-cenaby)*abslope_large
for y As Integer=y0 to y1
sc0x.da=sc1x.da: sc1x.da-=abslope_small
sc0x.ab=sc1x.ab: sc1x.ab+=abslope_large
Dim As single xL1=-1,xL0=wm+1
da0=int_lo(sc1x.da,dxL): If da0<xL0 Then xL0=da0
da1=int_hi(sc0x.da,axR): If da1>xL1 Then xL1=da1
Dim As single xR1=-1,xR0=wm+1
ab0=int_lo(sc0x.ab,axL): If ab0<xR0 Then xR0=ab0
ab1=int_hi(sc1x.ab,bxR): If ab1>xR1 Then xR1=ab1
For x as integer=xL0 to xR1
a(x)=1
Next
subt_da da0,da1
subt_ab ab0,ab1,y
If y=ayi And xbound(ax) Then
a(axL)+=area_oversubtracted(ax,ay,axL,ayi)
EndIf
scanwrite xL0,xR1,y
next
end sub
sub AaLine.scanlines_cdb(y0 as integer, y1 as integer)
if y0<0 then y0=0
if y1>hm then y1=hm
for y As Integer=y0 to y1
sc0x.cd=sc1x.cd: sc1x.cd+=abslope_large
sc0x.bc=sc1x.bc: sc1x.bc-=abslope_small
Dim As single xL1=-1,xL0=wm+1
cd0=int_lo(sc0x.cd,dxL): If cd0<xL0 Then xL0=cd0
cd1=int_hi(sc1x.cd,cxR): If cd1>xL1 Then xL1=cd1
Dim As single xR1=-1,xR0=wm+1
bc0=int_lo(sc1x.bc,cxL): If bc0<xR0 Then xR0=bc0
bc1=int_hi(sc0x.bc,bxR): If bc1>xR1 Then xR1=bc1
For x as integer=xL0 to xR1
a(x)=1
Next
subt_bc bc0,bc1
subt_cd cd0,cd1,y
If y=cyi And xbound(cx) Then
a(cxR)+=area_oversubtracted(cx,cy,cxR+1,cyi+1)
EndIf
scanwrite xL0,xR1,y
next
end sub
sub AaLine.scanlines_db(y0 as integer, y1 as single)
if y0<0 then y0=0
if y1>hm then y1=hm
for y As Integer=y0 to y1
sc0x.ab=sc1x.ab: sc1x.ab+=abslope_large
sc0x.cd=sc1x.cd: sc1x.cd+=abslope_large
Dim As single xL1=-1,xL0=wm+1
cd0=int_lo(sc0x.cd,dxL): If cd0<xL0 Then xL0=cd0
cd1=int_hi(sc1x.cd,cxR): If cd1>xL1 Then xL1=cd1
Dim As single xR1=-1,xR0=wm+1
ab0=int_lo(sc0x.ab,axL): If ab0<xR0 Then xR0=ab0
ab1=int_hi(sc1x.ab,bxR): If ab1>xR1 Then xR1=ab1
For x as integer=xL0 to xR1
a(x)=1
Next
subt_ab ab0,ab1,y
subt_cd cd0,cd1,y
scanwrite xL0,xR1,y
next
end sub
Sub AaLine.calc
handle_infinity
if slen <= 0 then exit sub
if im=0 or im->bpp <> 32 then
static as integer show_msg=1
if show_msg then
if im->im=0 then: ? "AaLine: invalid render target"
else: ? "AaLine: target must be 32bpp"
end if: sleep 1000: show_msg=0
endif
end if
init
octant
corners
if dyi<=byi then
scanlines_adb ayi,dyi-1
if dyi<byi-1 then
scanlines_abcd dyi, dyi
scanlines_db dyi+1, byi-1
scanlines_abcd byi, byi
else
scanlines_abcd dyi, byi
end if
scanlines_cdb byi+1,cyi
else
scanlines_adb ayi,byi-1
scanlines_abcd byi, dyi
scanlines_cdb dyi+1,cyi
end if
End sub
sub AaLine.draw(_x0 as single,_y0 as single,_x1 as single,_y1 as single,_col as ulong)
x0=_x0: x1=_x1: y0=_y0: y1=_y1: col=_col: calc
end sub
sub AaLine.draw_by_vec(x as single, y as single, slen as single, angle as single,_col as ulong)
slen /= 2: dim as single sina = slen*sin(angle), cosa = sLen*cos(angle)
x0=x-cosa: x1=x+cosa: y0=y-sina: y1=y+sina: col=_col: calc
end sub
sub AaLine.drawme
calc
End Sub
'
' ------------------------ AaLine
function chaos(x as single,c as single) as single
x*=c
dim as ulong ptr px=cast(ulong ptr,@x)
*px and=&h007fffff
*px or=&h3f800000
return x-1!
end function
var w = 640
var h = 480
dim as imagevars buf
buf.screen_init w,h
dim as aaline aa
aa.render_target buf
aa.wid = 2.5
aa.alpha = .5
aa.endcap = 0.0625
var yscale = buf.hm
var y_top = buf.hm / 2 + yscale / 2
screenlock
cls
var xstep = 5
dim as single y0=.3, x0
for x as ulong=1 to buf.wm step xstep
var y=chaos(y0,.51)
aa.draw x0, y_top - yscale*(1-y0),x, y_top - yscale*(1-y)
x0=x
y0=y
next
screenunlock
getkey