Aa Lines

User projects written in or related to FreeBASIC.
dafhi
Posts: 1238
Joined: Jun 04, 2005 9:51

Aa Lines

Postby dafhi » Dec 24, 2012 18:10

https://github.com/dafhi/anti-aliased-gfx-primitives

slightly older

Code: Select all

'#include "inc/aaline.bas"
' ---- aaline.bas

'#include once "imagevars.bas"
' ------- imagevars 2018 Jan 9 - by dafhi --------

#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

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          '' 2018 Jan 9 - 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 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,, 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
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 )
          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_
 
  For yDest As myint = yTop To yBot
 
    Dim As myint  yGrid = yDest + ClipTop
   
    Dim As single     lerp = (yGrid - yTop) / hgt_
    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
      Dim As Single   sGrn
      Dim As Single   sBlu
     
      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

      pixDest[xDest].B = sBlu
      pixDest[xDest].G = sGrn
      pixDest[xDest].R = sRed

    Next
  Next
 
End Sub

#ifndef pi
const   TwoPi = 8*atn(1)
const   Pi = 4*atn(1)
const   piBy2 = 2*atn(1)
const   iPi = 1/Pi
const   piBy4 = atn(1)
#EndIf
'
' -------- imagevars

/' -- Anti-aliased lines - 2018 Jan 10 - by dafhi

  ' - usage -----------------------
  dim as imagevars      buf
  buf.screen_init 800,600

  aaline.render_target @buf
  screenlock
    line buf.im, (0,0)-(buf.wm, buf.hm), rgb(180,175,160), bf
    aaline.wid = 50
    aaline.draw 100,100,400,300, rgb(255,255,255)
  screenunlock:  sleep
  ' --------------------------------
 
  I will update this project as time permits.
  http://www.freebasic.net/forum/viewtopic.php?f=8&t=20719
'/

namespace AaLine
 
  dim As single               x0,y0,x1,y1,wid=1,endcap
  dim As ulong                col = -1
 
  dim As imagevars ptr        im
 
  '' private
  Type ScanIntercepts
    as double                 ab,cd,bc,da
  End Type

  dim As single               sx0,sy0,sx1,sy1,ax,bx,cx,dx,ay,by,cy,dy
  dim As single               ayi,byi,cyi,dyi
  dim As single               dxL,bxR,axL,axR,cxL,cxR
  dim As ulong ptr            cBL,cBR,cTL,cTR  'window pixels: bottom-left, ..
  dim As integer              w,wm,hm,pitchx,pitchy,wmprev,hmprev
  dim As single               abslope_small, abslope_large
  dim As single               slen,swid, sdx,sdy, angle, scosa,ssina, cenx,ceny
  dim As Single               lenBy2, smallBy2,largeBy2
  dim As single               da0,da1,ab0,ab1,bc0,bc1,cd0,cd1
  dim As single               cenabx, cenaby, cencdx, cencdy
  dim As integer              yflipped, xyflipped
  dim As ScanIntercepts       sc0x, sc1x, sc0y, sc1y
  dim As single               a(Any), _alpha
 
  Sub render_target(byref p as imagevars ptr): im = p '2017 Sep 10
  end sub
 
  sub 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*(col shr 24)/255
  End sub
 
  Sub yflip
    pitchy=-pitchy: yflipped=-1
    swap cBL,cTL: swap cBR,cTR
    ceny=hm+1-ceny: ssina=-ssina
  end sub
 
  sub xyflip
    swap cTL,cBR: xyflipped = -1
    swap wm,hm: swap pitchx,pitchy
    swap cenx,ceny: swap scosa,ssina
  end sub
 
  sub re_center
    lenBy2=slen/2
    scosa=cos(angle)*lenBy2: ssina=sin(angle)*lenBy2
    var dx0=im->wh-x0, dy0=im->hh-y0 ''
    var dx1=im->wh-x1, dy1=im->hh-y1 ''
    const c = .5
    if dx0*dx0+dy0*dy0 < dx1*dx1+dy1*dy1 then 'point 0 closest to center
      cenx=x0+scosa+c ''
      ceny=y0+ssina+c ''
    else
      cenx=x1-scosa+c ''
      ceny=y1-ssina+c ''
    endif
  end sub
 
  sub 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

    '' fix to make compiler happy
    if angle=0 or abs(angle-pi)<0.00001 then angle += 0.0001
   
    scosa=cos(angle)*lenBy2: ssina=sin(angle)*lenBy2
  End sub
 
  Sub octant
    if scosa<0 then scosa=-scosa: ssina=-ssina
    if ssina<0 then yflip
    if ssina>scosa then xyflip
    w=wm+1
    ax=cenx-scosa: bx=cenx+scosa  '2017 June 4
    ay=ceny-ssina: by=ceny+ssina  '2017 June 4
  End sub
 
  sub 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
    cx=bx-hdxwid: dx=ax-hdxwid: ax=ax+hdxwid: bx=bx+hdxwid  '2017 June 4
    cy=by+hdywid: dy=ay+hdywid: ay=ay-hdywid: by=by-hdywid  '2017 June 4
    ayi=floor(ay): byi=floor(by): cyi=floor(cy): dyi=floor(dy)
    dxL=floor(dx): axL=floor(ax): axR=floor(ax)
    bxR=floor(bx): cxL=floor(cx): cxR=floor(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 xbound(x As Single) As Integer
    return x>=0 And x<w
  End Function
 
  Function ybound(yLo As single,yHi As single,y As single) As Integer
    return y>=yLo And y<= yHi
  End Function
 
  Function 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 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 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 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 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 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 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 int_lo(in As Single,clip As Single) As Single
    If in<clip Then: Return floor(clip): Else: Return floor(in): EndIf
  End Function
 
  Function int_hi(in As Single,clip As Single) As Single
    If in>clip Then: Return floor(clip): Else: Return floor(in): EndIf
  End Function
 
  sub 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 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 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 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 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 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 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 drawme
    calc
  End Sub
end namespace ' ---- aaline

namespace dodi_gfx
 
  sub render_target(byref p as imagevars ptr)
    aaline.render_target p
    aaline.endcap = .5
  End Sub
 
  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
      aaline.wid = size * .03
      aaline.draw 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
end namespace


screenres 800,600,32

dim as imagevars buf:  buf.get_info
'dim as imagevars tex:  tex.get_info imagecreate( 400, 300, rgb(0,0,0) )

dodi_gfx.render_target @buf
for i as long = 1 to 60
  with buf
    #define r255 int(rnd*256)
    #define rcol rgb(r255,r255,r255)
    dodi_gfx.tree rnd*.w, .h-rnd*.hh*1.1, (rnd+.1)*.diagonal/4, 15*(rnd-.5)+90, 1+rnd*11, rcol, rcol, .im
    screenlock: screenunlock
  end with
  'put (0,0), tex.im, pset
next

sleep
Last edited by dafhi on Jan 13, 2018 1:35, edited 81 times in total.
dodicat
Posts: 5697
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: rectangles

Postby dodicat » Dec 24, 2012 21:15

Hi Dafhi
I don't have the #include file, but from your previous post I had a guess.

Code: Select all

 '#Include "..\imageinfo.bi"
'Declare Function                ScreenInit(ByVal pWid As UShort=1,ByVal pHgt As UShort=1,ByVal bpp_ as UInteger=32,ByVal pRed As UByte=127,ByVal pGrn As UByte=127,ByVal pBlu As UByte=127,ByVal pAph As UByte=255) As Any Ptr
#include "vbcompat.bi" '' string formatting
#Include "fbgfx.bi"
Using FB
#Ifndef UnionARGB
  Union UnionARGB
    Type
      As UByte  B
      As UByte  G
      As UByte  R
      As UByte  A
    End Type
    As UInteger ARGB
  End Union
#EndIf
Type srSngPoint
    As Single                     x,y
End Type
Type ImageInfo
  As Any ptr                      img = 0
  As Any ptr                      pixels
  As Any ptr                      botleft
  As Integer                      pitchm
  As Integer                      pitch
  As Integer                      wid
  As Integer                      hgt
  As Integer                      widM
  As Integer                      hgtM
  As single                       midx
  As single                       midy
  As Single                       diagonal
  As Single                       aaL,aaR,aaT,aaB
  As Integer                      bypp
  As Integer                      pitchBy4
  As Integer                      UB1D
  As Integer                      w_plus_h
  As srSngPoint                   ptA,ptB,ptC,ptD
  Declare Operator                Cast () As Any Ptr
  Declare Function                Create(ByVal pWid As UShort=1,ByVal pHgt As UShort=1,ByVal bpp_ as UInteger=32,ByVal pRed As UByte=127,ByVal pGrn As UByte=127,ByVal pBlu As UByte=127,ByVal pAph As UByte=255,ByVal NoImage As Integer=0) As Any ptr
  Declare Function                ScreenInit(ByVal pWid As UShort=1,ByVal pHgt As UShort=1,ByVal bpp_ as UInteger=32,ByVal pRed As UByte=127,ByVal pGrn As UByte=127,ByVal pBlu As UByte=127,ByVal pAph As UByte=255) As Any Ptr
  Declare sub                     LoadBMP(ByRef filename As String)
 
  Declare Sub                     Blit(ByRef Dest As ImageInfo,ByVal X As Integer = 0,ByVal Y As Integer = 0, ByVal Wid As Integer = -1, ByVal Hgt As Integer = -1)
  Declare Sub                     SkewRect_ScaleRotate(ByVal scale_ As Single = 1.0, ByVal angle_ As Single = 0.0)
  Declare Sub                     SkewRect_Render(ByRef pDest As ImageInfo, _
    ByVal x As Integer = 0, _
    ByVal y As Integer = 0, _
    ByVal wid As Integer = -1, _
    ByVal hgt As Integer = -1)
  Declare Sub ScrInfo
  Declare Sub Cls( ByVal pColor As UInteger=RGBA(0,0,0,0) )
  Declare Sub Destroy
  Declare Sub varsCommon
  Declare Destructor
End Type
Destructor ImageInfo
  Destroy
End Destructor
Sub ImageInfo.Destroy()
  If img = 0 Then Exit Sub
  ImageDestroy img
  img = 0
End Sub

Operator ImageInfo.cast () As Any Ptr
  Return img
End Operator
Function ImageInfo.ScreenInit(ByVal pWid As UShort,ByVal pHgt As UShort,ByVal bpp_ as UInteger,ByVal pRed As UByte,ByVal pGrn As UByte,ByVal pBlu As UByte,ByVal pAph As UByte) As Any Ptr
  ScreenRes pWid,pHgt,bpp_
  ScrInfo
  Return pixels
End Function
Sub ImageInfo.ScrInfo
  ScreenInfo wid ,hgt  , , bypp, pitch
  pixels = ScreenPtr
  varsCommon
End Sub
Sub ImageInfo.varsCommon
  widM = wid - 1
  hgtM = hgt - 1
  midx = widM * 0.5
  midy = hgtM * 0.5
  UB1D = wid * hgt - 1
  pitchm = pitch - 1
  pitchBy4 = pitch \ 4
  botleft = pixels + pitch * hgtm
  w_plus_h = wid + hgt
  diagonal = Sqr(wid * wid + hgt * hgt)
  aaL = -0.5
  aaR = widM + 0.5
  aaB = -0.5
  aaT = hgtM + 0.5
End Sub
Sub ImageInfo.Cls( ByVal pColor As UInteger)
  Dim As UInteger cpy_ = (pitch * hgt) Shr 2
  Dim As UInteger Ptr dest = pixels
  ''http://www.freebasic.net/forum/viewtopic.php?t=15809&
  Asm mov eax, [pcolor]
  Asm mov edi, [dest]
  Asm mov ecx, [cpy_]
  Asm rep stosd
End Sub
'Using FB

#Ifndef pi
Const                   TwoPi = 8 * Atn(1)
Const                   pi    = 4 * Atn(1)
  #EndIf

' ------------------------- '
'  FPS limit approximation  '
'                           '

Dim shared as double    time_delta
dim shared as double    time_old
dim shared as double    time_new

Dim As Integer          FrameN
Dim As Single           time_sum, fps, fps_every = 1.0
Dim As String           strFPS

#Macro FramesPerSecond(target_)

  If target_ > 0.05 Then
    Scope '' limiter
   
      Dim As Single target_secs = 1 / (1.0 *(target_))
      Dim As Single tNow = Timer
      Dim As Single tDelt = tNow - time_new
     
      If tDelt < target_secs Then
     
        target_secs -= tDelt
       
        Dim As Single tweak1 = 0.0001
        Dim As Single tweak2 = 0.999
       
        Dim As Single tNext = tNow + (target_secs - tweak1) * tweak2
       
        Dim As Integer  sleepval = 1
        If target_secs > 0.04 Then sleepval = 2
       
        While Timer < tNext
          Sleep sleepval, 1
        Wend
       
      End If
     
    End Scope
  End If
 
  '' fps calculation
 
  If time_sum > fps_every Then
    strFPS = Format( FrameN / time_sum , "###.#" )
    FrameN = 0: time_sum = 0
  EndIf

  time_old = time_new
  time_new = timer
  time_delta = time_new - time_old
 
  FrameN += 1
  time_sum += time_delta
   
#EndMacro
'                 '
' --------------- '

' -------------------- '
'        aaLine        '
'                      '

#Ifndef FALSE
Const FALSE = 0
Const TRUE = not FALSE
  #EndIf

Type aaSng2D
  As Single         x,y
End Type

Type aaLine
  As aaSng2D        P1,P2
  As Single         wid = 1.0
  As UnionARGB      Color
  Declare Sub       DrawMe(ByRef pImg As ImageInfo)
  Declare sub       SetPoints(ByVal x1 As Single=0,ByVal y1 As Single = 0, ByVal x2 As Single = 0, ByVal y2 As Single = 0)
  Declare Sub       LenWidAnglePos(ByVal posx As Single=10, ByVal posy As Single=10,ByVal len_ As Single=10, ByVal angle_ As Single=0, ByVal wid_ As Single=1)
End Type
  #Macro ScanLine()
 
      X1 = xPosL
      X2 = xPosR
      If X1 < uxmin_ Then X1 = uxMin_
      If X2 > uxmax_ Then X2 = uxmax_

      ptr_pixel = pImg.pixels
      ptr_pixel += pitchY * Y_ + pitchX * X1
     
      For lp_pix As UInteger Ptr = ptr_pixel To ptr_pixel + pitchX * (X2 - X1) Step pitchX
        *lp_pix = Color.ARGB
      Next
     
      xPosL += lerpL
      xPosR += lerpR
     
  #EndMacro
  #Macro ScanLines_Section(Y0_,Y1_)
 
    If Sect_ValA < 3 Then
      Sect_Below = Sect_ValA
      Y2 = Y1_ - 1
    Else '' scanline of highest vtx
      Sect_Below = 2
      Y2 = Y1_
    End If
   
    lerpIncr = 1 / (sngVtxL(Sect_ValB).y - sngVtxL(Sect_Below).y)
    lerpL = lerpIncr * (sngVtxL(Sect_ValB).x - sngVtxL(Sect_Below).x)
    lerpR = lerpIncr * (sngVtxR(Sect_ValB).x - sngVtxR(Sect_Below).x)

    deltL = Y0_ - sngVtxL(Sect_Below).y
    deltR = deltL

    If lerpL < 0 Then
      deltL += 1
    EndIf
    If lerpR > 0 Then
      deltR += 1
    EndIf
   
    xPosL = sngVtxL(Sect_Below).x + lerpL * deltL
    xPosR = sngVtxR(Sect_Below).x + lerpR * deltR
   
    uxMin_ = LimL(Sect_ValB)
    uxMax_ = LimR(Sect_ValB)
    If uxMin_ < 0 Then uxMin_ = 0
    If uxMax_ > XMAX_ Then uxMax_ = XMAX_
   
    For Y_ = Y0_ To Y2
      ScanLine()
    Next
   
  #EndMacro
  #Macro zMulti_Y(YT_,YB_,sngPt)
    YB_ = sngPt.y
    YT_ = YB_
    If YB_ < 0 Then YB_ = 0
    If YT_ > ymax_ Then YT_ = ymax_
  #EndMacro
  #Macro ClipT_ClipB()
    zMulti_Y( Y0T_,Y0B_,sngVtxL(0) )
    zMulti_Y( Y1T_,Y1B_,sngVtxL(1) )
    zMulti_Y( Y2T_,Y2B_,sngVtxL(2) )
    zMulti_Y( Y3T_,Y3B_,sngVtxL(3) )
  #EndMacro
 
  #Macro zSpliceHorizontal(Vtx1_V,Vtx2_V,p0x,p1x,p2x,p3x,p0y,p1y,p2y,Vtx2,Vtx1)

    Vtx1_V = Type(p1x,p1y)
    Vtx2_V = type(p2x,p2y)
   
    lerp = (p1y - p0y) / (p2y - p0y)
    lerp *= p2x - p0x
    Vtx2.x = p0x + lerp
    Vtx2.y = p1y

    Vtx1.x = p3x - lerp
    Vtx1.y = p2y
   
  #EndMacro
  #Macro SpliceHorizontal(ax,bx,cx,dx,ay,by,cy,dy)
 
    LimL(1) = bx
    LimR(1) = dx
    LimL(2) = bx
    LimR(2) = dx
    LimL(3) = bx
    LimR(3) = dx
   
    If by < dy Then
      zSpliceHorizontal( sngVtxL(1), sngVtxR(2), _
        ax,bx,dx,cx, ay,by,dy, _
        sngVtxR(1), sngVtxL(2) )
      IsVtxL(1) = 1: IsVtxR(1) = 0
      IsVtxL(2) = 0: IsVtxR(2) = 1
    Else
      zSpliceHorizontal( sngVtxL(2), sngVtxR(1), _
        cx,bx,dx,ax, cy,by,dy, _
        sngVtxR(2), sngVtxL(1) )
      IsVtxL(1) = 0: IsVtxR(1) = 1
      IsVtxL(2) = 1: IsVtxR(2) = 0
    End If'/
   
    sngVtxL(0) = Type(ax,ay)
    sngVtxR(0) = sngVtxL(0)
    sngVtxL(3) = Type(cx,cy)
    sngVtxR(3) = sngVtxL(3)
    IsVtxL(3) = 1
    IsVtxR(3) = 1
   
  #EndMacro
  #Macro ScanLines(ax,bx,cx,dx,ay,by,cy,dy,XMAX,YMAX)
   
    xmax_ = XMAX: ymax_ = YMAX
   
    SpliceHorizontal(ax,bx,cx,dx,ay,by,cy,dy)
    ClipT_ClipB()
   
    Sect_ValA = 0
    Sect_ValB = 1
    ScanLines_Section(Y0B_, Y1T_)
    Sect_ValA = 1
    Sect_ValB = 2
    ScanLines_Section(Y1B_, Y2T_)
    Sect_ValA = 2
    Sect_ValB = 3
    ScanLines_Section(Y2B_, Y3T_)
    Sect_ValA = 3
    Sect_ValB = 3
    ScanLines_Section(Y3B_, Y3T_)
   
  #EndMacro

Sub aaLine.DrawMe(ByRef pImg As ImageInfo)

  Locate 1,1
 
  Dim As Single     widBy2 = 0.5 * wid
  Dim As Single     rise_ = P2.y - P1.y
  Dim As Single     run_ = P2.x - P1.x
 
  Dim As aaSng2D    pt1_ = Any
  Dim As aaSng2D    pt2_ = Any

  Dim As Single     roun = 0.5
 
  If rise_ < 0  And run_ < 0 Then
    rise_ = -rise_
    run_ = -run_
    pt1_ = Type( P2.x+roun, P2.y+roun )
    pt2_ = Type( P1.x+roun, P1.y+roun )
  Else
    pt1_ = type( P1.x+roun, P1.y+roun )
    pt2_ = type( P2.x+roun, P2.y+roun )
  EndIf
 
  Dim As Single     len_ = Sqr( rise_*rise_ + run_*run_ )
  Dim As Single     sin_ = rise_ / len_
  Dim As Single     cos_ = run_ / len_
  Dim As Single     perpY = sin_ * widBy2
  Dim As Single     perpX = cos_ * widBy2
 
  Dim As Single     ax_ = pt1_.x + perpY, ay_ = pt1_.y - perpX
  Dim As Single     bx_ = pt1_.x - perpY, by_ = pt1_.y + perpX
  Dim As Single     cx_ = pt2_.x - perpY, cy_ = pt2_.y + perpX
  Dim As Single     dx_ = pt2_.x + perpY, dy_ = pt2_.y - perpX
 
  Dim As aaSng2D    sngVtxL(3)=Any
  Dim As aaSng2D    sngVtxR(3)=Any
  Dim As Integer    IsVtxL(1 To 3) = Any
  Dim As Integer    IsVtxR(1 To 3) = Any
  Dim As Integer    LimL(1 To 3) = Any
  Dim As Integer    LimR(1 To 3) = Any
 
  Dim As Single     slo_ = Any, iSlo_ = Any
  Dim As Integer    Y0T_ = Any, Y1T_ = Any
  Dim As Integer    Y2T_ = Any, Y3T_ = Any
  Dim As Integer    Y0B_ = Any, Y1B_ = Any
  Dim As Integer    Y2B_ = Any, Y3B_ = Any

  Dim As Integer    X1 = Any, X2 = Any, X_ = Any
  Dim As Integer    Y1 = Any, Y2 = Any, Y_ = Any
  Dim As Integer    pixel_top = Any
  Dim As Integer    Sect_ValA = Any, Sect_ValB = Any, Sect_Below = Any
 
  Dim As Single     lerp = Any
  Dim As Single     xPosL = Any, deltL = Any
  Dim As Single     xPosR = Any, deltR = Any
  Dim As Single     lerpL=Any, lerpR=Any
  Dim As single     lerpIncr = Any
 
  Dim As UInteger   pitchX = Any, pitchY = Any
  Dim As UInteger   xMax_ = Any, yMax_ = Any
  Dim As Integer    uxMin_ = Any, uxMax_ = Any
 
  Dim As UInteger ptr ptr_pixel = Any
  If rise_ = 0 Then
    If run_ > 0 Then
    ElseIf run_ < 0 Then
    Else '' run_ = 0
      '' nothing to do
    EndIf
  ElseIf rise_ > 0 Then
    If run_ > 0 Then
      iSlo_ = run_ / rise_
      If rise_ > run_ Then
        pitchX = 1: pitchY = pImg.pitchBy4
        ScanLines(ax_,bx_,cx_,dx_,ay_,by_,cy_,dy_, pImg.widm,pImg.hgtm)
      Else '' rise <= run
        pitchX = pImg.pitchBy4: pitchY = 1
        ScanLines(by_,ay_,dy_,cy_,bx_,ax_,dx_,cx_, pImg.hgtm,pImg.widm)
      EndIf '' rise > run
    ElseIf run_ < 0 Then
      If rise_ > -run_ Then
        pitchX = pImg.pitchBy4: pitchY = 1
        ScanLines(cy_,by_,ay_,dy_,cx_,bx_,ax_,dx_, pImg.hgtm,pImg.widm)
      Else
        pitchX = 1: pitchY = pImg.pitchBy4
        ScanLines(bx_,cx_,dx_,ax_,by_,cy_,dy_,ay_, pImg.widm,pImg.hgtm)
      EndIf
    Else '' run_ = 0
    EndIf '' run <>= 0
  Else '' rise_ < 0
 
    '' if rise and run were both < 0, they were changed to positive
 
    If run_ > 0 Then
      If run_ < -rise_ Then
        pitchX = pImg.pitchBy4: pitchY = 1
        ScanLines(ay_,dy_,cy_,by_,ax_,dx_,cx_,bx_, pImg.hgtm,pImg.widm)
      Else
        pitchX = 1: pitchY = pImg.pitchBy4
        ScanLines(dx_,ax_,bx_,cx_,dy_,ay_,by_,cy_, pImg.widm,pImg.hgtm)
      EndIf
    Else '' run_ = 0
    EndIf
  EndIf
 
End Sub
Sub aaLine.SetPoints(ByVal x1 As Single, ByVal y1 As Single, ByVal x2 As Single, ByVal y2 As Single)
  P1.x = x1: P1.y = y1: P2.x = x2: P2.y = y2
End Sub
Sub aaLine.LenWidAnglePos(ByVal posx As Single, ByVal posy As Single,ByVal len_ As Single, ByVal angle_ As Single, ByVal wid_ As Single)
  wid = wid_
  Dim As Single lenBy2 = 0.5 * len_
  Dim As Single cos_ = lenBy2 * Cos(angle_)
  Dim As Single sin_ = lenBy2 * Sin(angle_)
  P2.x = posx + cos_
  P2.y = posy + sin_
  P1.x = posx - cos_
  P1.y = posy - sin_
End Sub
'                  '
' ---------------- '

'' -------
'  Main
' -------

'' http://www.freebasic.net/forum/viewtopic.php?f=3&t=20669#p181983
Function get_fpu_control_word()as integer
    asm fstcw [function]
end function
Sub set_fpu_control_word(byval cw as integer)
    asm fldcw [cw]
end sub
Sub set_fpu_rounding_mode(byval mode as integer)
    mode=(get_fpu_control_word() and &hf3ff)or((mode and 3)shl 10)
    asm fldcw [mode]
end Sub
dim as integer original_fpu_control_word=get_fpu_control_word()

''  rounding mode:
'' 0=nearest
'' 1=round down
'' 2=round up
'' 3=truncate
set_fpu_rounding_mode(1)

' ==================================

Dim As ImageInfo  Img
Img.ScreenInit 480,360

Type MyData
  As Single             wid_, len_, px, py, angle, iangle
  As UInteger           Color
End Type

Dim As Integer          Num = 250
Dim As MyData           MyData(1 To Num)

Dim As Integer          Border = 50
Dim As Integer          BorX2 = 2 * Border

#Macro NewData()
  For I As Integer = 1 To Num
    With MyData(I)
      .wid_ = Rnd * 22 * Rnd * Rnd * rnd
      .len_ = 80 + Rnd * 100
      .px = -Border + Rnd * (Img.wid + BorX2)
      .py = -Border + Rnd * (Img.hgt + BorX2)
      .Color = RGB(Rnd*255,Rnd*255,Rnd*255)
      .angle = Rnd * twopi
      .iangle = Rnd * Rnd * Rnd * 0.008
    End With
  Next
#EndMacro

NewData()

Dim As aaLine           MyLine
MyLine.Color.ARGB = 167

Dim As EVENT  e

time_old = Timer

Dim As Single           t_trigger_val = 10
Dim As Single           t2 = time_old + t_trigger_val

Dim As Integer          Running = 1

Do While Running

    FramesPerSecond( 60 )
   

    ScreenLock
    img.Cls RGB(120,110,50)
   
    For I As Integer = 1 To Num
      With MyData(I)
        MyLine.LenWidAnglePos( .px, .py, .len_, .angle, .wid_ )
        .angle += .iangle
        MyLine.Color.ARGB = .Color
      End With
      MyLine.DrawMe Img
    Next

    Locate 1,1
    ? "FPS: " ; strFPS
   
    ScreenUnLock
   
    If (ScreenEvent(@e)) Then
      if e.type = EVENT_KEY_PRESS Then
        Select Case e.scancode
        Case SC_ESCAPE
          Running = 0
        Case Else
          Running = 0
        End Select
      End If
    End If
   
    If time_new >= t2 Then
      t2 = time_new + t_trigger_val
      NewData()
    EndIf
   
Loop

'put the fpu back the way it was
set_fpu_rounding_mode(original_fpu_control_word)


Here's my humble effort:

Code: Select all

Sub thickline(x1 As Double,_
    y1 As Double,_
    x2 As Double,_
    y2 As Double,_
    thickness As Double,_
    colour As Uinteger)
    Dim As Double yp,s,h,c
    h=Sqr((x2-x1)^2+(y2-y1)^2)
    s=(y1-y2)/h
    c=(x2-x1)/h
    For yp=0 To thickness Step 1/(thickness)
        Line(x1+(s*yp),y1+(c*yp))-(x2+(s*yp),y2+(c*yp)),colour
    Next yp
End Sub
Function framecounter() As Integer
    Var t1=Timer,t2=t1
    Static As Double t3,frames,answer
    frames=frames+1
    If (t2-t3)>=1 Then
        t3=t2
        answer=frames
        frames=0
    End If
    Return answer
End Function
Function regulate(MyFps As Integer,Byref fps As Integer) As Integer
    fps=framecounter
    Static As Double timervalue
    Static As Double delta,lastsleeptime,sleeptime
    Var k=1/myfps
    If Abs(fps-myfps)>1 Then
        If fps<Myfps Then delta=delta-k Else delta=delta+k
    End If
    sleeptime=lastsleeptime+((1/myfps)-(Timer-timervalue))*(2000)+delta
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=Timer
    Return sleeptime
End Function
Type d2
    As Single x,y
    As Single angle,thickness
    As Uinteger col
    As Integer direction
    As Single inc
End Type
#define r(f,l) (Rnd*((l)-(f))+(f))
#define Intrange(f,l) int(Rnd*((l+1)-(f))+(f))
#macro rotate(pivot,p,a,d)
Type<d2>(d*(Cos(a*.0174533)*(p.x-pivot.x)-Sin(a*.0174533)*(p.y-pivot.y)) +pivot.x,_
d*(Sin(a*.0174533)*(p.x-pivot.x)+Cos(a*.0174533)*(p.y-pivot.y)) +pivot.y)
#endmacro
Screenres 600,600,32
Color ,Rgb(100,50,0)
Dim As Integer d,numlines=50
Dim As d2 pt1(1 To numlines)
Dim As d2 pt2(1 To numlines)
Dim As d2 pivot(1 To numlines)
For z As Integer=1 To numlines
    pt1(z)=Type<d2>(r(0,800),r(0,600))
    pt2(z)=Type<d2>(r(0,400),r(00,300))
    pivot(z)=Type<d2>((pt1(z).x+pt2(z).x)/2,(pt1(z).y+pt2(z).y)/2)
    pivot(z).angle=r(0,360)
    pivot(z).col=Rgb(r(0,255),r(0,255),r(0,255))
    pivot(z).thickness=r(1,10)
    pivot(z).inc=r(.1,1)
    Do
        d=IntRange(-1,1)
        pivot(z).direction=d
    Loop Until d<>0
Next z
Dim As d2 rot
Dim As Single angle
Dim As Integer fps,sleepytime
Do
    Screenlock
    sleepytime=regulate(45,fps)
   
    Cls
    Draw String(10,10),"FPS " & fps
    For z As Integer=1 To numlines
        pivot(z).angle=pivot(z).angle+pivot(z).inc
        angle=pivot(z).angle*pivot(z).direction
        Var rot1= rotate(pivot(z),pt1(z),angle,1)
        Var rot2= rotate(pivot(z),pt2(z),angle,1)
        thickline rot1.x,rot1.y,rot2.x,rot2.y,pivot(z).thickness,pivot(z).col
    Next z
    Screenunlock
    Sleep sleepytime,1
Loop Until Len(Inkey)
Sleep
dafhi
Posts: 1238
Joined: Jun 04, 2005 9:51

Re: rectangles

Postby dafhi » Dec 24, 2012 22:34

looks like you nabbed my code before I realized I hadn't replaced include
Last edited by dafhi on Jan 10, 2018 8:36, edited 2 times in total.
dodicat
Posts: 5697
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: rectangles

Postby dodicat » Dec 25, 2012 2:27

Hi Dafhi
Tonight here I would say 10 degrees centigrade, we have a lovely S.W. breeze off the ocean, the land is a bit waterlogged just now, but for Christmas it is just perfect.
My favourite wind is from the South West, straight off the Ocean and fragrant, you can smell the breeze, exotic almost.
What's it like in your neck of the woods tonight?
dafhi
Posts: 1238
Joined: Jun 04, 2005 9:51

Re: rectangles

Postby dafhi » Dec 25, 2012 3:20

there's about 2 inches of snow and we've been having nights of -7C. speaking of scents, dairy cardboard from the freezer

after a flu, I feel bathed in light. assisted by a citrus diet, I can then experience a fragrant superradiance. at higher intensities, octaves float about
dafhi
Posts: 1238
Joined: Jun 04, 2005 9:51

Re: Aa Rects

Postby dafhi » Oct 27, 2015 6:01

Got em working! (check first post)
dafhi
Posts: 1238
Joined: Jun 04, 2005 9:51

Re: Aa Rects

Postby dafhi » Nov 05, 2015 9:36

fixed 2 linux bugs. should be working now
D.J.Peters
Posts: 7667
Joined: May 28, 2005 3:28

Re: Aa Rects

Postby D.J.Peters » Nov 05, 2015 13:22

You are clever and select a soft background color ;-)
On black background you can see the aliases border lines are not good weighted.

I get the flickering effect (from rotating borders) on my high quality display.

This is the job of aliasing to remove or reduce this frquency drift effect. (so far I know)

I don't say my version would be better but looks like you have to do a little bit more work to make it near perfect :-)

However good job so far.

Joshy
dafhi
Posts: 1238
Joined: Jun 04, 2005 9:51

Re: Aa Rects

Postby dafhi » Nov 05, 2015 14:14

updated :-)
dafhi
Posts: 1238
Joined: Jun 04, 2005 9:51

Re: Aa Lines

Postby dafhi » Aug 06, 2016 0:19

Anybody feel like moving this to Tips & Tricks?

Thanks
MrSwiss
Posts: 3025
Joined: Jun 02, 2013 9:27
Location: Switzerland

Re: Aa Lines

Postby MrSwiss » Aug 06, 2016 21:26

Unfortunately NOT working with FBC 64 bit (asm code errors, seems to be 32 bit only).
dafhi
Posts: 1238
Joined: Jun 04, 2005 9:51

Re: Aa Lines

Postby dafhi » Aug 06, 2016 23:39

works fine here - FreeBASIC Compiler - Version 1.05.0 (10-02-2015), built for win64 (64bit)
dodicat
Posts: 5697
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Aa Lines

Postby dodicat » Aug 06, 2016 23:49

Hi Dafhi

Tested -gen gas 32 bit,-gen gcc 32 bit and 64 bit gcc with -exx then without -exx.

System:
FBIde: 0.4.6
FreeBASIC Compiler - Version 1.05.0 (01-31-2016). built for win32 (32bit) and built for win64 (64bit)
OS: Windows NT 6.2 (build 9200)

(Windows 10)

Runs OK
Tourist Trap
Posts: 2754
Joined: Jun 02, 2015 16:24

Re: Aa Lines

Postby Tourist Trap » Aug 07, 2016 0:11

On xp-win32, perfect.
dafhi
Posts: 1238
Joined: Jun 04, 2005 9:51

Re: Aa Lines

Postby dafhi » Jan 13, 2018 1:35

now on github

Return to “Projects”

Who is online

Users browsing this forum: No registered users and 4 guests