sine fractals

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
Post Reply
dafhi
Posts: 1640
Joined: Jun 04, 2005 9:51

sine fractals

Post by dafhi »

first version can be found a few posts below

[Updates]
2013 Oct 16 - gcc-friendly
2013 Oct 03 (below) - fixed (dfield.bi) UB1D calculation -> [new] UB1D = h * .. [old] UB1D = w * ..

dfield.bi

Code: Select all

'' ---------- dfield.bi ----------- ''

'' changes - 2013 Oct 03 - bugfix

'' Delta Field morphs by dafhi

'  A continuing work inspired by early winamp visual plugins

' Logic from the "FlowField" description ..
' http://www.soundspectrum.com/g-force/Documentation/background.html

' Other plugins of the same type
' http://www.geisswerks.com/about_geiss.html
' http://www.winamp.com/visualization/acidspunk/19079


'#include "timageZ.bi"

'' ----------- tImage.bi ------------ ''
#Ifndef TRUE
Const FALSE = 0
Const TRUE = not FALSE
  #EndIf

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

const as double           sqr2 = sqr(2)

#define r255              rnd * 255
#define rm5               Rnd - 0.5

const                     white = &HFFFFFFFF

#Macro sim_speed(secs_per_frame)
  dim as double   _t = Timer, secperframe = (secs_per_frame)
  dim as integer  nFrames
  while t < _t: t += secperframe: nFrames += 1: Wend
  dim as single gspeed = secperframe * nframes
#EndMacro


Type tImage
  As Any ptr              img=0
  as uinteger ptr         topleft,botleft,botright
  As Integer              w,h,wm,hm,pitchm,pitch,bpp,bypp,pitchBy,is_screen,num_pages,UB1D,br_
  As single               midx,midy,diagonal
  Declare Sub             screen_init(pWid As UShort=1,pHgt As UShort=1,numPages as integer=1,Flags as integer=0,bpp_ as UInteger=32)
  Declare Function        create(pWid As UShort=1,pHgt As UShort=1, color_ As UInteger=RGB(127,127,127), NoImage As Integer=0) As Any ptr
  Declare Sub             destroy
  Declare Sub             Cls( ByVal pColor As UInteger=RGB(0,0,0) )
  Declare Sub             blit( dest as tImage ptr, x as integer=0, y as integer=0 )
  Declare Sub             Print(str_ As String, X As Integer=0, Y As Integer=0,Color_ As UInteger = &HFFFFFFFF)
  Declare sub             LoadBMP(ByRef filename As String)
  declare sub             iflip
  declare sub             checker_background(CheckerSize As UInteger = 12,pColor As UInteger=RGBA(145,145,145,255))
  Declare Destructor
 Private:
  Declare sub             UpdateInfo
  Declare Sub             ScrInfo
  Declare Sub             varsCommon
End Type
  Destructor tImage: Destroy: End Destructor
Sub tImage.Destroy(): If img = 0 Then Exit Sub
  ImageDestroy img: img = 0
End Sub
sub tImage.iflip
  locate 1,1
  if not is_screen then exit sub
  if num_pages > 1 then: flip
  else: screenlock: screenunlock: end if
End Sub
Sub tImage.varsCommon
  wm = w - 1: hm = h - 1
  midx = wm * 0.5: midy = hm * 0.5
  pitchBy = pitch \ bypp
  UB1D = h * pitchBy - 1: pitchm = pitch - 1
  botleft = topleft: botleft += pitchBy * hm
  botright = botleft + wm: br_ = ub1d - pitchBy - 1
  diagonal = Sqr(wm * wm + hm * hm) / 2
End Sub
sub tImage.UpdateInfo: ImageInfo img, w, h, bypp, pitch, topleft: End Sub
Sub tImage.ScrInfo: ScreenInfo w,h, bpp, bypp, pitch: topleft = ScreenPtr: varsCommon: End Sub
Sub tImage.screen_init(Wid As UShort,Hgt As UShort,_
                       numPages as integer,Flags as integer,bpp_ as UInteger)
  Destroy: num_pages = numpages: ScreenRes Wid,Hgt,bpp_,numPages,Flags: ScrInfo: img=0: is_screen=TRUE: if numPages > 1 then screenset 0,1
End sub
Function tImage.create(pWid As UShort,_
                       pHgt As UShort,_
                       color_ As UInteger,_
                       NoImage As Integer) As Any Ptr
  Destroy: If NoImage Then
  w = pWid: h = pHgt
  Else: img = ImageCreate( pWid, pHgt, color_, 32 )
  UpdateInfo: EndIf: varsCommon: is_screen=FALSE: Return img
End Function
  Sub tImage.checker_background(CheckerSize As UInteger,pColor As UInteger)
Dim As UInteger SizeDouble=CheckerSize*2,SizeM=CheckerSize-1
For Y as integer = 0 To hm Step CheckerSize
For X as integer = -CheckerSize * ((Y/SizeDouble)=Int(Y/SizeDouble)) To wm Step SizeDouble
Line this.img,(X,Y)-(X+SizeM,Y+SizeM),pColor,BF
Next
Next
End Sub
  Sub tImage.Print(str_ As String, X As Integer, Y As Integer,Color_ As UInteger)
Draw String img,(X,Y),str_,Color_
End Sub
  Sub tImage.Cls( ByVal pColor As UInteger)
Dim As UInteger cpy_ = (pitch * h) \ bypp
Dim As UInteger Ptr dest = topleft ''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
  #Macro cpy_varadd(reg, var, add_to_var, reg_tmp)
    mov reg, [var]
    mov reg_tmp, reg
    add reg_tmp, [add_to_var]
    mov [var], reg_tmp
  #EndMacro
sub tImage.blit( dest as tImage ptr, _x1 as integer, _y1 as integer )

  dim as integer  x1 = _x1, x2 = x1 + wm:  if x1 < 0 then x1 = 0
  dim as integer  y1 = _y1, y2 = y1 + hm:  if y1 < 0 then y1 = 0
  
  if x2 > dest->wm then x2 = dest->wm
  if y2 > dest->hm then y2 = dest->hm

  dim as integer      cols = x2 - x1 + 1: if cols < 1 then exit sub
  dim as integer      rows = y2 - y1 + 1: if rows < 1 then exit sub
  dim as integer      qcols = cols \ 4, cols_remainder = cols - qcols * 4 '' unroll variables

  dim as integer      x_sav_ecx, y_sav_ecx '' ASM loops
  dim as integer      _pitch = pitch, pitch_dst = dest->pitch
  dim as uinteger ptr src = topleft, dst = dest->topleft + y1 * dest->pitchBy + x1

  '' shortcut of saying "if _y1 < 0 then _y1 = 0"
  src += _y1 * (_y1 < 0) * pitchBy + _x1 * (_x1 < 0)

  asm

    mov ecx, [rows]

    yLoopBlit:                                '' unique labels across app
      mov [y_sav_ecx], ecx                    '' prepare to use ecx for anything

      '' will use this macro in future projects
      cpy_varadd( esi, src, _pitch, edx )      '' esi = [src], increase src by pitch, edx is temp
      cpy_varadd( edi, dst, pitch_dst, edx )  '' edi = [dst], increase dst by pitch_dst, ..

      mov ecx, [qcols]                        '' column quad rollout
      cmp ecx, 0
      jle xLoopRemainder                      '' if ecx <= 0 jump xLoopRemainder

      xLoopBlitQuad:                          '' all ASM labels in one app must be unique

        mov eax, [esi]                        '' mov [edi], [esi] is not acceptable in asm
        mov [edi], eax                        ''
        mov eax, [esi+4]                      '' src
        mov [edi+4], eax                      '' dst
        mov eax, [esi+8]                      '' src
        mov [edi+8], eax                      '' dst
        mov eax, [esi+12]                     '' src
        mov [edi+12], eax                     '' dst

        add esi, 16                           '' src ptr
        add edi, 16                           '' dst ptr
      dec ecx                                 '' end xLoop
      jnz xLoopBlitQuad

      xLoopRemainder:
      mov ecx, [cols_remainder]               '' done with quads, now process remaining pixels
      cmp ecx, 0                              ''
      jle yLoopEnd                            '' skip xLoopBlit if ecx <= 0

      xLoopBlit:                              '' all ASM labels in one app must be unique
        mov eax, [esi]                        '' mov [edi], [esi] is not acceptable in asm
        mov [edi], eax                        ''
        add esi, 4                            '' src
        add edi, 4                            '' dst
      dec ecx                                 '' end xLoop
      jnz xLoopBlit

    yLoopEnd:
    mov ecx, [y_sav_ecx]                      '' end yLoop
    dec ecx
    jnz yLoopBlit

  end asm

end sub
Sub tImage.LoadBMP(ByRef filename As String)
  Open filename For Input As #1
  If Lof(1) = 0 Then
    Close #1
    Exit sub
  EndIf
  Dim As Integer w,h
  Open filename For Binary As #1
  Get #1, 19, w
  Get #1, 23, h
  Close #1
  Create w,h
  Bload filename,Img
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

type tFPU     ''  http://www.freebasic.net/forum/viewtopic.php?f=3&t=20669#p181983
              '' 0=nearest
              '' 1=round down
              '' 2=round up
              '' 3=truncate
  as integer    original
  declare sub   set_rounding_mode(mode as integer)
  declare sub   restore:declare constructor:declare destructor
End Type
constructor tFPU: dim as integer ori: asm fstcw [ori]
  original=ori: set_rounding_mode 1: End Constructor
destructor tFPU: restore: End Destructor
sub tFPU.restore
  dim as integer ori = original:  asm fldcw [ori]
End Sub
Sub tFPU.set_rounding_mode(mode as integer)
  dim As integer ori: asm fstcw [ori]
  mode=ori and &hf3ff or (mode and 3)shl 10: asm fldcw [mode]
end Sub


Type tFPS
  As String               report
  As Single               target = 50.0, fps_report_every = 1.0
  As Single               fps_low_limit = 0.05, sFPS,sSPF,secs_per_frame,target_prev
  As Double               time_delta,time_old,time_now,time_sum,fps_trig_next
  As integer              new_report,Frame_,fTurbo, Turbo = 1 '' Experimental .. for FPS > 999
  Declare sub             Tick(target_fps As Single = 0.0)
  Declare Sub             DecPlaces(pInput As Single, Places As UByte =1)
End Type
  #Macro tFPS_LimFPS_Init()
If target_fps = 0 Then: target_fps = target
Else: target = target_fps: EndIf
If target <> target_prev Then target_prev = target: secs_per_frame = 1 / target
If time_now = 0 Then time_now = Timer: fps_trig_next = time_now + secs_per_frame/2: Frame_ = -1
#EndMacro
  #Macro FPS_CALC()
Frame_ += 1:time_sum += time_delta:new_report = 0
  If time_sum >= fps_report_every Then
sSPF = time_sum / Frame_:sFPS = Frame_ / time_sum
DecPlaces( Int(sFPS*10 + 0.5) / 10, 1 )
Frame_ = 0: time_sum = 0: new_report = 1: EndIf
#EndMacro
  Sub tFPS.DecPlaces(pInput As Single, Places As UByte)
If Places > 5 Then Places = 5
report = Str( pInput )
For I As Integer = 0 To Len(report)-1
  If report[I] = 46 Then report = Left(report,I+Places+1): Exit For
Next: report = Left( report + "   ", 6 ): End Sub
Sub tFPS.Tick(target_fps As Single)
  tFPS_LimFPS_Init()
  time_old = time_now: time_now = Timer
  time_delta = time_now - time_old
  FPS_CALC()
  If target_fps > fps_low_limit Then
    If time_now < fps_trig_next Then
      Sleep 1000 * (fps_trig_next - time_now): fps_trig_next += secs_per_frame
    Else: If fTurbo = Turbo Then Sleep 1,1: fTurbo = 0
      fTurbo += 1: fps_trig_next = secs_per_frame * Int(1.0+time_now / secs_per_frame)
    End If
  Else: Sleep 1,1 '' low fps target, just sleep 1
  EndIf: Locate 1,1 ''print pos
End Sub

Type SineCandy
  as single         bas,vari,angle,iangle,usr_tick,usr_tock=piBy2
  declare sub       set_vals(base as single=1,vari as single=0.5,iangle as single=0)
  declare function  usr_detect(reset_val as integer=2) as integer
  declare Operator  cast as single
End Type
function SineCandy.usr_detect(reset_val as integer) as integer
  dim as integer ret
  if usr_tick >= usr_tock then
    dim as single   udiv = angle / piBy2
    dim as integer  i = udiv
    if i and 1 then usr_tick = angle: usr_tock = piBy2 + pi * reset_val
    ret = -1
  end if: return ret
end function
sub SineCandy.set_vals(base_ as single,vari_ as single,iangl as single)
  vari=vari_: iangle=iangl: bas=base_
End Sub
Operator SineCandy.Cast as single
  return bas + Sin(angle)*vari
End Operator
'' -------------- end of tImage.bi ----------------- ''

'' -------------- dfield.bi continued ----------------- ''
type rotation_grid
  as double           pixdist, angle, cosa,sina, gcos,gsin, cosa_dith,sina_dith
  as double           tlx,tly, posx,posy
  declare sub         tl_incr
end type
sub rotation_grid.tl_incr
  posx = tlx: posy=tly: tlx += sina: tly -= cosa
end sub

type vec2d
  as single           x,y
end Type

type dfpixel
  as integer          a,b,c,d,off
end type

type delta_field
  as integer          w,h, wm,hm, x,y, x0,y0, x1,y1, wm_,hm_, frame
  as double           field_view = twopi*10, _tick, morph_trigger
  as single           midx, midy, OneOverBig
  as single           morph, morph_prev
  as string ptr       d0,d1,dresult,_df_newform
  as tImage ptr       _back, _fore
  as byte             border = 0
  declare sub         dims(w as integer = 100, h as integer = 100)
  declare sub         pos(x as integer = 0, y as integer = 0)
  declare sub         set_clipper(_w as integer, _h as integer)
  declare sub         tl_calc(byref g as rotation_grid, cx as double=0,cy as double=0, field_rad as double=1, angle as single=0, g_ang_delta as single=0)
  declare sub         next_formula()
  declare sub         morph_speed(increment as single = 0.01, time_before_new as single = 15)
  declare sub         render(byref buf as tImage, _x as integer=0, _y as integer=0)
  declare sub         renderMMX(byref buf as tImage, _x as integer=0, _y as integer=0)
  declare sub         render_one_frame(byref buf as tImage, _x as integer=0, _y as integer=0)
  declare sub         trigger_morph
  declare sub         _morph
  declare constructor
 private:
  as rotation_grid    g0, g1, g2
  as integer          img_pitch, img_wm,img_hm, img_tl, bor, bor_img_tl, bor_img_br
  as integer          _dither, _dswitch, one_more_dither, do_not_blit
  declare sub         checkswap
  as string           df(2)
  as tImage           img(1)
end type
constructor delta_field: _back=@img(0):_fore=@img(1): d0=@df(0): d1=@df(1): dresult = @df(2): end constructor
sub delta_field.set_clipper(_w as integer, _h as integer):  img_wm = _w-1: img_hm = _h-1: end sub
sub delta_field.tl_calc(byref g as rotation_grid, cenx as double, ceny as double, rad as double, angl as single, g_ang_delta as single)
  dim as double dx = x - x0 + midx
  dim as double dy = y - y0 + midy
  g.pixdist = rad * OneOverBig: g_ang_delta += angl
  g.gcos = cos(g_ang_delta): g.gsin = sin(g_ang_delta)
  g.cosa = g.pixdist * cos(angl)
  g.sina = g.pixdist * sin(angl)
  g.tly = ceny + dy * g.cosa + dx * g.sina
  g.tlx = cenx + dy * g.sina - dx * g.cosa
  g.sina = -g.sina
end sub
sub delta_field.dims(_w as integer, _h as integer)
  w = _w: wm = w-1: midx = wm/2
  h = _h: hm = h-1: midy = hm/2
  OneOverBig = 1 / ( sqr2 * sqr( midx*midx + midy*midy ) )
  df(0) = string( w*h*len(vec2d), 0 )
  df(1) = df(0): df(2) = string( w*h*len(dfpixel), 0 )
  bor = cint(border)
  img(0).create w+2*bor, h+2*bor
  img(1).create img(0).w, img(0).h
  set_clipper img(0).w, img(0).h
  img_pitch = _fore->pitch
  pos border,border
  morph = 0: next_formula: morph = 1: next_formula: morph_prev = 0
end sub
sub delta_field.pos(_x as integer, _y as integer)
  x = _x: x0 = x: x1 = x + wm: if x0 < 0 then x0 = 0
  y = _y: y0 = y: y1 = y + hm: if y0 < 0 then y0 = 0
  if x1 > img_wm then x1 = img_wm
  if y1 > img_hm then y1 = img_hm
  wm_ = x1 - x0: hm_ = y1 - y0
  img_tl = y0 * img_pitch + x0
  bor_img_tl = -y0 * img_pitch - x0
  bor_img_br = _fore->br_ + bor_img_tl
end sub
sub delta_field.trigger_morph
  morph = 0: next_formula: _tick = 0: morph_prev = 1
end sub
sub delta_field.morph_speed(increment as single, time_before_new as single)
  _tick += increment
  if _tick < 1 then
    frame += 1
    if frame = 2 then
      morph = _tick
      frame = 0
    end if: morph_trigger = Timer + time_before_new
  elseif Timer >= morph_trigger then
    trigger_morph
  end if
end sub
sub delta_field.checkswap
  if abs(0 - morph) < abs(1 - morph) then: _df_newform = d0
  else _df_newform = d1
  end if
  if abs(morph - morph_prev) >= 0.5 then swap d0, d1
end sub
sub delta_field.next_formula()
  checkswap
  dim as single r2
  #macro grid_topleft( g, cenx, ceny, rad )
    g.angle = Rnd*TwoPi
    tl_calc g, (cenx), (ceny), (rad), g.angle
    r2 = _fore->diagonal*(.15+rnd)/22
    g.gcos = r2: g.gsin = r2
  #endmacro
  grid_topleft( g0, rm5, rm5, (.15+rnd)*field_view )
  grid_topleft( g1, rm5, rm5, (.15+rnd)*field_view )
  grid_topleft( g2, rm5, rm5, (.15+rnd)*field_view )
  dim as single     off_y
  dim as vec2d ptr  topleft = @(*_df_newform)[0], botleft = @topleft[hm_ * w]
  for py as vec2d ptr = topleft to botleft step w
    g0.tl_incr: g1.tl_incr: g2.tl_incr
    dim as single       off_x
    for p as vec2d ptr = py to @py[wm_]
      #Macro whatev(off,xy,gcs,func,posxy,incr)
        p->xy = (off) + g0.gcs*func(g0.posxy) + g1.gcs*func(g1.posxy) + g2.gcs*func(g2.posxy)
        g0.posxy += g0.incr: g1.posxy += g1.incr: g2.posxy += g2.incr
      #EndMacro
      whatev(off_x,x,gcos,cos,posx,cosa)
      whatev(off_y,y,gsin,sin,posy,sina)
      off_x += 1
    next: off_y += 1
  next
end sub
sub delta_field._morph

  if morph = morph_prev then
    if one_more_dither then
      one_more_dither = false
    else
      exit sub
    end if
  else one_more_dither = true: morph_prev = morph
  end if

  dim as tFPU         FPU '' fpu round down

  const               a_max = 256

  dim as integer      scan_dith = _dswitch
  dim as single       min_ = -bor
  dim as single       maxx = min_ + img_wm - 1
  dim as single       maxy = min_ + img_hm - 1
  dim as single       dx,dy,idx,idy,a,b,c,d

  dim as vec2d ptr    _src = @(*d0)[0], __dst = @(*d1)[0]
  dim as dfpixel ptr  _res = @(*dresult)[0]

  for _dst as vec2d ptr = __dst to @__dst[hm_ * w] step w
    dim as vec2d ptr    src = _src + scan_dith
    dim as dfpixel ptr  res = _res + scan_dith
    for dst as vec2d ptr = @_dst[scan_dith] to @_dst[wm_] step 2
      #macro mac_pos_lim(v,max)
        dim as single v = src->v + morph * (dst->v - src->v)
        if v < min_ then: v = min_
        elseif v > max then v = max: end if
      #endmacro
      mac_pos_lim(x,maxx)
      mac_pos_lim(y,maxy)
      dim as integer intx = x, inty = y
      res->off = inty*img_pitch + intx shl 2
      dx = x - intx: idx = 1 - dx
      dy = y - inty: idy = a_max * (1 - dy): dy *= a_max
      res->a = idx * idy
      res->b = dx * idy
      res->c = idx * dy
      res->d = dx * dy
      src += 2: res += 2
    next: _src += w: _res += w: scan_dith = 1 - scan_dith
  next: _dswitch = 1 - _dswitch

end sub
Sub delta_field.render(byref buf as tImage, _x as integer, _y as integer)

  dim as integer  rows = hm_ + 1, cols = wm_ + 1
  if rows < 2 or cols < 2 then exit sub

  _morph

  dim as dfpixel ptr        _udt = @(*dresult)[0]
  dim as uinteger ptr       _dst = @_back->topleft[img_tl]
  dim as uinteger ptr       _src = @_fore->topleft[img_tl]
  dim as uinteger           pitch = _fore->pitch, pitch_udt = w * len(dfpixel)
  dim as uinteger           sav_udt, sav_dst, sav_ecx_x, sav_ecx_y

  asm
    mov ecx, [rows]                         '' outer loop  For Y = 0 to height - 1
    yLoop:

      cpy_varadd( edi, _udt, pitch_udt, ebx ) '' udt: 4 alpha pre-calcs, 1 offset
      cpy_varadd( edx, _dst, pitch, ebx )     '' rect top left

      mov [sav_ecx_y], ecx                    ''  prep. For X = 0 to width - 1
      mov ecx, [cols]
      xLoop:

        mov esi, [_src]                       '' [source ptr]
        add esi, [edi + 16]                   '' _src += [_udt->offset]

        mov [sav_dst], edx                    '' restore edx at end of xLoop
        mov [sav_ecx_x], ecx                  '' restore ecx ..

        #Macro mask_then_mul(maskval)
          mov eax, [esi]                      '' eax = source
          and eax, maskval                    '' AG or RB
          imul eax, [edi]                     '' eax by _udt->(alpha)
        #EndMacro

        mask_then_mul(&HFF00FF00)             '' source pixel "A" (top left)
        mov ecx, eax                          '' store AG in ecx
        mask_then_mul(&H00FF00FF)             '' multiplies by [edi]
        mov ebx, eax                          '' store RB in ebx

        #Macro mask_mul_rb_ag(add_subt_edi, add_subt_esi, edi_amt, esi_amt)
          add_subt_edi edi, edi_amt           '' add/sub edi, 4
          add_subt_esi esi, esi_amt           '' add/sub esi, 4
          mask_then_mul(&HFF00FF00)           '' imul [edi]
          add ecx, eax                        '' AG Sum
          mask_then_mul(&H00FF00FF)
          add ebx, eax                        '' RB Sum
        #EndMacro

        mask_mul_rb_ag(add, add, 4, 4)        '' source pixel "B" (top right)
        mask_mul_rb_ag(add, add, 8, [pitch])  '' source pixel "D" (bot right)
        mask_mul_rb_ag(sub, sub, 4, 4)        '' source pixel "C" (bot left)

        add ebx, &H00800080                   '' " + 0.5"
        add ecx, &H00008000                   '' " + 0.5"
        and ebx, &HFF00FF00
        and ecx, &H00FF0000

        or ebx, ecx
        shr ebx, 8
        mov edx, [sav_dst]                    '' restore dst ptr
        mov [edx], ebx                        '' [_dst] = Red Blue

        add edi, 12                           '' [c]  <skip>  d  <skip>  offset  <skip>  [next udt->a]
        add edx, 4                            '' _dst

      mov ecx, [sav_ecx_x]                    '' inside loop
      dec ecx
      jnz xLoop

    mov ecx, [sav_ecx_y]                      '' restore ecx
    dec ecx                                   '' Decrease ECX
    jnz yLoop                                 '' if ECX <> zero

  end asm

  swap _back, _fore
  if not do_not_blit then _back->blit @buf, _x, _y

End Sub
sub delta_field.renderMMX(byref buf as tImage, _x as integer, _y as integer)

  dim as integer  rows = hm_ + 1, cols = wm_ + 1
  if rows < 2 or cols < 2 then exit sub

  _morph

  dim as dfpixel ptr        _udt = @(*dresult)[0]
  dim as uinteger ptr       _dst = @_back->topleft[img_tl]
  dim as uinteger ptr       _src = @_fore->topleft[img_tl]
  dim as uinteger           pitch = _fore->pitch, pitch_udt = w * len(dfpixel)
  dim as uinteger           sav_ecx_x, sav_ecx_y
  dim as ulongint           L00FF = &H00FF00FF00FF00FF
  dim as ulongint           LFF00 = &H00000000FF00FF00
  dim as ulongint           L0080 = &H0000000000800080

  asm
    mov ecx, [rows]                                 '' outer loop  For Y = 0 to height - 1
    yLoop2:

      cpy_varadd( edi, _udt, pitch_udt, eax )       '' udt: 4 alpha pre-calcs, 1 offset
      cpy_varadd( edx, _dst, pitch, eax )           '' rect top left

      mov [sav_ecx_y], ecx                          ''  prep. For X = 0 to width - 1
      mov ecx, [cols]
      xLoop2:

        mov esi, [_src]                             '' esi = [_src]
        add esi, [edi + 16]                         '' _src += [_udt->offset]

        #Macro AB_or_CD(mmAG, mmRB)
          movq mmRB, [esi]                          '' ARGBARGB (top 2 pixels of src quad)
          pand mmRB, [L00FF]                        '' _R_B_R_B
          movq mmAG, [esi]                          '' ARGBARGB
          psrld mmAG, 8                             '' _ARG_ARG (packed shift right dword)
          pand mmAG, [L00FF]                        '' _A_G_A_G

          movq mm7, [edi]                           '' [0000000A][0000000B] (alphas A and B)
          pslld mm7, 16                             '' [000A0000][000B0000]
          por mm7, [edi]                            '' [000A000A][000B000B]

          pmullw mmRB, mm7                          '' RB packed multiply low (4x 16 bits in parallel)
          pmullw mmAG, mm7                          '' AG packed multiply low (4x 16 bits in parallel)
        #EndMacro

        AB_or_CD(mm0,mm2)                           '' AB
        add edi, 8                                  '' _udt->c
        add esi, [pitch]                            '' _src += pitch
        AB_or_CD(mm1,mm3)                           '' CD

        #Macro combine_top_bot_left_right(top, bot, reg)
          paddd top, bot                            '' A with C, B with D
          movq  bot, top                            '' combine dwords of Top - step 1 of 3
          psrlq bot, 32                             '' step 2
          paddd top, bot                            '' step 3
          paddd top, [L0080]                        '' + 00800080 integer round before mask
          movd reg, top                             '' reg = result
          and reg, &HFF00FF00                       ''
        #EndMacro

        combine_top_bot_left_right( mm0, mm1, eax ) '' AG
        combine_top_bot_left_right( mm2, mm3, ebx ) '' RB

        shr ebx, 8                                  '' RB
        or eax, ebx                                 '' ARGB
        mov [edx], eax                              '' tada!!

        add edi, 12                                 '' udt ptr
        add edx, 4                                  '' dst ptr

      dec ecx                                       '' inside loop
      jnz xLoop2                                    ''

    mov ecx, [sav_ecx_y]                      '' restore ecx
    dec ecx                                   '' Decrease ECX
    jnz yLoop2                                '' if ECX <> zero

    emms                              '' empty mmx state

  end asm

  swap _back, _fore
  _back->blit @buf, _x, _y

end sub
sub delta_field.render_one_frame(byref buf as tImage, _x as integer, _y as integer)
'  trigger_morph
: _morph
  do_not_blit = -1: render( buf, _x, _y ): do_not_blit = 0
  swap _back, _fore: _back->blit @buf, _x, _y
end sub
test.bas

Code: Select all

#include "dfield.bi"
type aaLine_UsrVars
  as single         angle,iangle,len
  as SineCandy      x,y,sclen,scwid,sclum
  As UInteger       color,color2
End Type


Sub NewRectParms(byref buf as tImage, byref auv as aaLine_UsrVars, wsize as single = 1)
  #define       sr Rnd*255
  #define       sg Rnd*255
  #define       sb Rnd*255
  dim as single wid_base = 2.75 + rnd * 17.5
  dim as single wid_vari = wid_base * 0.2 * (1-rnd*rnd)
  dim as single wid_iAngle = 0.01 * (rnd + 0.1)
  auv.scwid.set_vals wid_base*wsize, wid_vari*wsize, wid_iangle
  dim as single len_base = 25 + 300 * Rnd '* Rnd
  dim as single len_vari = Rnd * 8
  dim as single len_iAngle = 0.06 * (rnd + 0.1)
  auv.sclen.set_vals len_base*wsize, len_vari*wsize, len_iAngle
  auv.x.set_vals buf.midx, buf.midx * 1.1, 0.001 * (rnd + 1.5)
  auv.y.set_vals buf.midy, buf.midy * 1.1, 0.001 * (rnd + 1.5)
  auv.x.angle = rnd * twopi
  auv.y.angle = rnd * twopi
  auv.angle = Rnd * pi
  auv.iangle = 0.05 * (0.2 + Rnd * Rnd * (Rnd-0.5))
  auv.Color = RGB(sr,sg,sb)
  if rnd < 0.5 then
    auv.Color2 = &HFFFFFFFF
  else
    auv.Color2 = &HFF000000
  end if
  auv.sclum.set_vals 128.5, 128, 0.04 * (rnd + 0.1)
  auv.sclum.angle = rnd*twopi
end sub

#Macro NewCircles()
  dim as single wsize = buf.diagonal / 500
  NewRectParms( buf, MyData(1), wsize )
  for i as aaLine_UsrVars ptr = @MyData(2) to @MyData(Rectangles)
    if rnd < 0.3 then NewRectParms( buf, *i, wsize )
  Next
  trigger_new_lines = FPS.time_old + time_new_lines
#EndMacro

#Macro UpdateCircles(dest)
  dim as single rot_spd = gspeed * TwoPi * 10
  for i as aaLine_UsrVars pointer = @MyData(1) to @MyData(Rectangles)
      dim as integer  alpha = i->sclum, am = 256 - alpha
      dim as uinteger col
      Alpha256( col, i->Color, i->Color2, am, alpha )
      circle dest, (i->x, i->y), i->scwid, col', , , , F
      i->x.angle += i->x.iangle * rot_spd
      i->y.angle += i->y.iangle * rot_spd
      i->sclen.angle += i->sclen.iangle * rot_spd
      i->scwid.angle += i->scwid.iangle * rot_spd
      i->sclum.angle += i->sclum.iangle * rot_spd
      i->angle += i->iangle * rot_spd
  Next
#EndMacro


sub Main

  Randomize
 
  Dim As Single         tDemoSecs = 240
  #Define               time_new_lines  8

  Dim As Integer        Rectangles = 250
  Dim As aaLine_UsrVars MyData(1 To Rectangles)

  dim as tFPS           FPS
  dim as delta_field    df
  dim as tImage         buf
  dim as integer        Border = 1
  dim as integer        BorX2 = 2 * Border
  dim as single         angle

  buf.screen_init 640, 520, 2
  df.dims buf.w-BorX2, buf.h-BorX2

  Dim As Single         tDemoExit, trigger_new_lines: tDemoExit = Timer + tDemoSecs

  dim as double         t = Timer
  while 1

    FPS.Tick 23
    If FPS.time_now >= tDemoExit Then locate 3,2: ? "demo finished.  exiting ..": flip: sleep 1600: Exit while

    dim as string kstr = inkey
    if kstr = chr(27) then exit while
    kstr = lcase(kstr)
    if kstr = "f" then df.trigger_morph: angle = 0
    if kstr = "k" then df.morph = 4 * (rnd - 0.5)

    If FPS.time_now >= trigger_new_lines Then
      NewCircles()
    EndIf

    df.render buf, Border, Border

    '? FPS.report
    buf.iflip

    sim_speed(1/100)
   
    dim as any ptr  des = df._fore->img
    UpdateCircles(des)
   
    dim as double time_before_new = 23
    df.morph_speed gspeed * .82, time_before_new

  wend

end sub

Main
Last edited by dafhi on Aug 08, 2016 3:14, edited 26 times in total.
Gonzo
Posts: 722
Joined: Dec 11, 2005 22:46

Re: sine fractals

Post by Gonzo »

if you used a different seed for each "area" you could create a fractal system that creates continental boundries
very nice demo though =)
i am hoping for a 3d function out of this!
dafhi
Posts: 1640
Joined: Jun 04, 2005 9:51

Re: sine fractals

Post by dafhi »

I recently had a look at Ryan Geiss' 3d terrains write-up. Fascinating stuff.
Gonzo
Posts: 722
Joined: Dec 11, 2005 22:46

Re: sine fractals

Post by Gonzo »

if you are interested in 3d terrain i would love to have you on my project =)
in whatever capacity you want.. i have an external generator that creates compressed terrain which can run using my voxel engine

i have recently created a new type of noise called cosnoise, which if you combine it with gfreq noise can be used to cut into 3d terrain
http://fbcraft.fwsnet.net/cnoise_v2_2.png
as you can see theres overhangs and ridged cuts over that example island
dafhi
Posts: 1640
Joined: Jun 04, 2005 9:51

Re: sine fractals

Post by dafhi »

original Sine Fractals post

Code: Select all

'' 2012 Feb 21 - sine fractals  by dafhi

#Include "fbgfx.bi"
#Include "vbcompat.bi"

#Ifndef TRUE
#Define TRUE -1
#EndIf
#Ifndef FALSE
#Define FALSE 0
#EndIf

Dim Shared As Integer               SCR_W = 400
Dim Shared As Integer               SCR_H = 300

Dim Shared As Integer               WidM: WidM = SCR_W - 1
Dim Shared As Integer               HgtM: HgtM = SCR_H - 1

Dim Shared As Double                SCR_DIAGONAL:SCR_DIAGONAL = Sqr(WidM^2+HgtM^2)
Dim Shared As Double                ar_x: ar_x = WidM / SCR_DIAGONAL
Dim Shared As Double                ar_y: ar_y = HgtM / SCR_DIAGONAL
Dim Shared As Single                mcenterx, mcentery, mfield_view

Dim Shared As Double                fps_timer = 1,starting_time, primary_time, prev_time
Dim Shared As Double                delta_sum, delta_time
Dim Shared As String                fps_string: fps_string = "0"
Dim Shared As Integer               FrameN,Flipper,FlipBright

Dim Shared As Single                mAngle ''general purpose sine variable

Dim Shared As Const Double          TwoPi = 8 * Atn(1)
Dim Shared As Const UInteger        GrayScaleRGB = 1 + 256 + 65536

Type FieldSpecs
   As Single                        freqX1,freqX2,freqY1,freqY2
   As Single                        amp2, field_view
   As Single                        x1,y1,xstep,ystep
End Type

Type DeltaPel
   As Single                        x,y
End Type

Dim Shared As DeltaPel              dp()
Dim Shared As FieldSpecs            fsp(1)

Type PelPelQuad
   As UInteger                      A
   As UInteger                      AMUL,BMUL,CMUL,DMUL
End Type

Dim Shared As PelPelQuad            fmap(WidM,HgtM)

Type ImageInfo
   As Any ptr                       img,pixels,topleft
   As Integer                       pitch,wid,hgt,bypp,pitchBy4,widM,hgtM,UB1D,pitchm
   Declare Sub Create(ByVal pWid As UShort=SCR_W,ByVal pHgt As UShort=SCR_H,ByVal pRed As UByte=127,ByVal pGrn As UByte=127,ByVal pBlu As UByte=127,ByVal pAph As UByte=255)
   Declare Sub Destroy
End Type

Sub ImageInfo.Create(ByVal pWid As UShort,ByVal pHgt As UShort,ByVal pRed As UByte,ByVal pGrn As UByte,ByVal pBlu As UByte,ByVal pAph As UByte)
   img = ImageCreate( pWid, pHgt, RGBA(pRed,pGrn,pBlu,pAph))
   ImageInfo img,wid ,hgt,bypp, pitch, pixels
   pitchBy4 = pitch \ 4
   widM = wid - 1
   hgtM = hgt - 1
   UB1D = wid * hgt - 1
   topleft = pixels + pitch * hgtm
   pitchm = pitch - 1
End Sub
Sub ImageInfo.Destroy()
   ImageDestroy img
End Sub

Dim Shared As ImageInfo            img(1)

' ----------------- Float-To-Int Begin ------------------ '
'                                                         '
'  http://www.freebasic.net/forum/viewtopic.php?p=61669&  '
'                                                         '
'                                                         '
#Macro SCW(i)
  asm
  sub esp,2
  fnstcw    [esp]
  mov   ax, [esp]
  and   ax, &HF3FF
  or    ax, &H0400
  mov   [i],ax
  fldcw [i]
#EndMacro
#Macro RCW()
  fldcw [esp]
  add   esp, 2
  end asm
#endmacro
#Macro CIntF(i,f)
  asm fld   dword ptr [f]
  asm fistp dword ptr [i]
#endmacro
#Macro FloorF(i,d)
  SCW(i)
  fld   dword ptr [d]
  fistp dword ptr [i]
  RCW()
#EndMacro
'                                    '
'                                    '
' -------- Float-To-Int End -------- '

' +--------------------------------------------+ '
' |                                            | '
' |               Helpers Begin                | '
' |                                            | '
' |                                            | '
Sub Blit(img As ImageInfo,ByVal ResetPrint_ As Integer = FALSE)
   Put (0,0),img.img,PSet
   If ResetPrint_ Then Locate 1,1
End Sub
Dim Shared As Single            mValByMod
Dim Shared As Integer           mIValByMod
#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))
#Macro Modulus(pValue,pModulus)
   mValByMod = floor(pValue / pModulus)
   pValue -= pmodulus * mValByMod
#EndMacro
Sub CheckerBoard(ByRef pImg As ImageInfo,ByVal CheckerSize As UInteger = 12,ByVal pColor As UInteger=RGBA(145,145,145,255),ByVal pWidM As Integer=WidM,ByVal pHgtM As Integer=HgtM)
Dim As Integer X, Y
   Dim As UInteger SizeDouble=CheckerSize*2,SizeM=CheckerSize-1
   For Y = 0 To pHgtM Step CheckerSize
      For X = -CheckerSize * ((Y/SizeDouble)=Int(Y/SizeDouble)) To pWidM Step SizeDouble
         Line pImg.img,(X,Y)-(X+SizeM,Y+SizeM),pColor,BF
      Next
   Next
End Sub
Sub Cls2(pColor As UInteger=RGBA(0,0,0,0),dest As UInteger Ptr=ScreenPtr)
Dim As UInteger local_pitch
ScreenInfo ,,,,local_pitch
Dim As UInteger cpy_ = (local_pitch * Scr_H) Shr 2

   ''Dr_D
   Asm mov eax, [pcolor]
   Asm mov edi, [dest]
   Asm mov ecx, [cpy_]
   Asm rep stosd
    
   Locate 1,1 'Reset print pos

End Sub

Sub FramesPerSecond(ByVal sine_speed As Double = 0, ByVal SetPrintPos As Integer = FALSE)
   If delta_sum > fps_timer Then
      fps_string = Format( FrameN / delta_sum , "###.#" )
      FrameN = 0: delta_sum = 0
   EndIf
   prev_time = primary_time
   primary_time = timer
   delta_time = primary_time - prev_time
   FrameN += 1
   delta_sum += delta_time
   If SetPrintPos Then Locate 1,1
   If sine_speed <> 0 Then
      mAngle += sine_speed * delta_time
      Modulus(mAngle,TwoPi)
   End If
End Sub
''                              ''
''         Helpers End          ''
''                              ''
'' ============================ ''

'' =========================================== ''
''                                             ''
''             Screen Melts Begin              ''
''                                             ''
''                                             ''
Sub Pixellate(img As ImageInfo,ByVal fullness As Single = 1)
Dim As Integer IU_ = img.UB1D * fullness
Dim As UInteger Ptr pixel
Dim As Single sng_, sngU = img.UB1D + 1
Dim As UInteger Int_
Dim As Single dx,dy,dySq,dist
Dim As Single midx = img.widM * 0.5
Dim As Single midy = img.HgtM * 0.5

      dySq = dy * dy
      For I As Integer = 1 To IU_
         sng_ = Rnd * sngU
         FloorF(Int_,sng_)
         pixel = img.pixels
         pixel += Int_
         dist = Rnd * 16777216
         FloorF(Int_,dist)
         *pixel = Int_
         pixel += 1
      Next

End Sub

#Macro CalcShr()
   Dim As Integer ShrAmt
ShrAmt = PelGrid * PelGrid
For A = 1 To 16
   ShrAmt Shr= 1
   If ShrAmt And &H1 Then ShrAmt = A: Exit For
Next
#EndMacro
Dim Shared As Integer               PelGrid
Dim Shared As Single BorderX = 0,BorderY = 0

Sub Melt(dst As ImageInfo,src As ImageInfo)
   Dim As PelPelQuad Ptr pfmap
   Dim As Integer X1=BorderX, Y1=BorderY
   Dim As Integer X2=dst.widM-X1
   Dim As Integer Y2=dst.hgtM-Y1
   Dim As UInteger AG, RB, R,G,B,A
   Dim As UInteger Ptr psrc,pdst
   
   CalcShr()
   For Y As Integer = Y1 To Y2
      pdst = dst.pixels
      pdst += dst.pitchBy4 * Y + X1
      pfmap = @fmap(X1,Y)
      For X As Integer = X1 To X2
         psrc = src.pixels
         psrc += pfmap->A
         RB = pfmap->AMUL * (*psrc And &H00FF00FF)
         AG = pfmap->AMUL * ((*psrc And &HFF00FF00) Shr ShrAmt)
         psrc += 1
         RB += pfmap->BMUL * (*psrc And &H00FF00FF)
         AG += pfmap->BMUL * ((*psrc And &HFF00FF00) Shr ShrAmt)
         psrc += src.pitchBy4
         RB += pfmap->CMUL * (*psrc And &H00FF00FF)
         AG += pfmap->CMUL * ((*psrc And &HFF00FF00) Shr ShrAmt)
         psrc -= 1
         RB += pfmap->DMUL * (*psrc And &H00FF00FF)
         AG += pfmap->DMUL * ((*psrc And &HFF00FF00) Shr ShrAmt)
         RB += &H00400040
         AG += &H00400040
         *pdst = ((RB Shr ShrAmt) And &H00FF00FF) Or (AG And &HFF00FF00)
         pdst += 1
         pfmap += src.hgt
      Next
   Next
   
End Sub
#Macro FieldFormComm_Constrain(pVal,LimLo,LimHi)
   If pVal < LimLo Then
      pVal = LimLo
   ElseIf pVal > LimHi Then
      pVal = LimHi
   End If
#EndMacro
#Macro AAPel_CornerA(sample_,RetAlph,Samp)
   pelLeft = sample_ - 0.5
   Samp = floor(sample_)
   pelboun = Samp + 0.5
   sAlph = sMul * (pelboun - pelLeft) + 0.5
   RetAlph = Floor(sAlph)
#EndMacro
Sub zFieldPelsToInt(map_() As PelPelQuad,imgRef As ImageInfo)
   Dim As UInteger MUL_Xi,MUL_Yi
   Dim As Single sx, sy
   Dim As Single sx_,sy_
   Dim As Single sx_FN, sy_FN
   Dim As Single x1=BorderX,y1=BorderY
   Dim As Single x2=imgRef.widM - x1
   Dim As Single y2=imgRef.hgtM - y1
   Dim As Single pelLeft,pelboun,sAlph
   Dim As Integer Mul_X,Mul_Y,X,Y,IncrPtrNested = 2 * imgRef.hgt
   Dim As Single sng_xi,sng_yi
   Dim As PelPelQuad Ptr pfmap
   Dim As UInteger Ptr pdst
   Dim As DeltaPel Ptr pdpA,pdpB
   Dim As Single XMAX = imgRef.widM - 1,YMAX = imgRef.hgtM - 1
   
   PelGrid = 16
   Dim As Single sMul = PelGrid,alph =60 '* Sin(mAngle) + 30.0

   For sy_FN = y1 To y2
      pfmap = @map_(x1,sy_FN)
      pdpA = @dp(x1,sy_FN,0)
      pdpB = @dp(x1,sy_FN,1)
      For sx_FN = x1 To x2

         sx_ = pdpA->x + alph * (pdpB->x - pdpA->x)
         sy_ = pdpA->y + alph * (pdpB->y - pdpA->y)
         
         FieldFormComm_Constrain(sx_,0,XMAX)
         FieldFormComm_Constrain(sy_,0,YMAX)

         AAPel_CornerA(sx_,MUL_X,X)
         AAPel_CornerA(sy_,MUL_Y,Y)
         MUL_Xi = PelGrid - MUL_X
         MUL_Yi = PelGrid - MUL_Y
         pfmap->AMUL = MUL_X * MUL_Y
         pfmap->BMUL = MUL_Xi * MUL_Y
         pfmap->CMUL = MUL_Xi * MUL_Yi
         pfmap->DMUL = MUL_X * MUL_Yi

         pfmap->A = Y * imgRef.pitchBy4 + X
         pfmap += imgRef.hgt
         pdpA += IncrPtrNested
         pdpB += IncrPtrNested
      Next
   Next
End Sub
Sub FieldPelsToInt(map_() As PelPelQuad)
   zFieldPelsToInt map_(), img(0)
End Sub
Dim Shared As Integer FieldsThrottle_FRAME
Sub LerpThrottle(ByVal Every_N_Frames As UInteger = 0)
   If Every_N_Frames <> 0 Then
      FieldsThrottle_FRAME += 1
      If FieldsThrottle_FRAME >= Every_N_Frames Then
         FieldPelsToInt fmap()
         Modulus(mAngle,TwoPi)
         FieldsThrottle_FRAME = 0
      EndIf
   End If
End Sub

Sub SawWave(ByRef ret As Single,ByVal in_ As Single)
   ret = in_ - Int(in_)
   ret -= 0.5
End Sub
Function SawW(ByVal in_ As Single) As Single
   in_ -= Int(in_)
   return in_ - 0.5
End Function
#Macro FormulaCommon()
   pdpA->x += xDbInt
   pdpA->y += yDbInt
   pdpA += IncrPtrNested
   x += pfsp->xstep
#EndMacro
Sub Splash(img As ImageInfo, ByVal Pixellate_ As Integer = FALSE, ByVal pixRate As Single = 0.002, ByVal DoCheckers As Integer = FALSE)
   Dim As UInteger Gray_ = FlipBright + 0: FlipBright = 255 - FlipBright
   If Pixellate_ Then Pixellate img, pixRate
   If DoCheckers Then CheckerBoard img, 5, RGBA(Gray_,Gray_,Gray_,128)
End Sub
Sub Formula(ByVal Page_ As Integer = 0)
   Dim As Single xend = WidM
   Dim As Integer yInt,IncrPtrNested = 2 * SCR_H
   Dim As Single dx,dy
   Dim As FieldSpecs Ptr pfsp = @fsp(Page_)
   Dim As Single freqX1 = pfsp->freqX1 * TwoPi
   Dim As Single freqY1 = pfsp->freqY1 * TwoPi
   Dim As Single freqX2 = pfsp->freqX2 * TwoPi
   Dim As Single freqY2 = pfsp->freqY2 * TwoPi
   Dim As Single amp1 = 0.3 / pfsp->field_view
   Dim As Single amp2 = pfsp->amp2
   Dim As Single x, y = pfsp->y1
   Dim As DeltaPel Ptr pdpA

   For yDbInt As Single = 0 To HgtM
      pdpA = @dp(0,yInt,Page_)
      x = pfsp->x1
      For xDbInt As Single = 0 To xend
         pdpA->x = amp1 * Sin(freqY1 * (y + amp2 * Sin(y*freqY2) ))
         pdpA->y = amp1 * Sin(freqX1 * (x + amp2 * Sin(x*freqX2) ))
         FormulaCommon()
      Next
      yInt += 1
      y += pfsp->ystep
   Next
End Sub

Dim Shared As Integer FF
Sub FormulaBoth()
   Formula FF
   Formula 1-FF
   FieldPelsToInt fmap()
End Sub
Sub zField_AmpFreq(ByVal scalar As Single, ByRef freqX As Single,ByRef freqY As Single,ByVal pVari As Single=1,pBase As Single= 1)
   freqX = (pbase + Rnd * pVari) * scalar
   freqY = (pbase + Rnd * pVari) * scalar
End Sub
Sub zFieldOfView(ByVal xcenter As Single,ByVal ycenter As Single, _
   ByVal DoRnd As Integer, FSPEC As FieldSpecs, _
   ByVal vari1 As Single,ByVal vari2 As Single, _
   ByVal base1 As Single,ByVal base2 As Single, _
   ByVal amp_ As Single,ByVal field_view As Single)

   With FSPEC
      .field_view = field_view
      Dim As Single scalar_ = Any
      If DoRnd Then
         scalar_ = 1
         zField_AmpFreq scalar_,.freqX1,.freqY1,vari1,base1
         zField_AmpFreq scalar_,.freqX2,.freqY2,vari2,base2
         .amp2 = amp_
      End If
      
      scalar_ = ar_x * field_view
      .x1 = xcenter - 0.5 * scalar_
      .xstep = scalar_ / WidM
      
      scalar_ = ar_y * field_view
      .y1 = ycenter - 0.5 * scalar_
      .ystep = scalar_ / HgtM
   End With
   
End Sub
Sub FieldOfView(ByVal xcenter As Single,ByVal ycenter As Single, _
   ByVal DoRnd As Integer = FALSE, ByVal field_view As Single = 1, _
   ByVal vari1 As Single = 1,ByVal vari2 As Single = 2, _
   ByVal base1 As Single = 2,ByVal base2 As Single = 10, _
   ByVal amp_ As Single = 0.01 + 0.5 * Rnd)
   
   zFieldOfView xcenter,ycenter,DoRnd,fsp(0),vari1,vari2,base1,base2,amp_,field_view
   zFieldOfView xcenter,ycenter,DoRnd,fsp(1),vari1,vari2,base1,base2,amp_,field_view
   FormulaBoth

End Sub
Sub ViewCenter()
   FieldOfView mcenterx, mcentery,,mfield_view
End Sub
' |                                      | '
' |          Screen Melts End            | '
' +--------------------------------------+ '

Using FB
Dim As EVENT e

ScreenRes SCR_W,SCR_H,32,, fb.GFX_ALPHA_PRIMITIVES

img(0).Create
img(1).Create

Splash img(1),TRUE,1,TRUE

ReDim fmap(WidM,HgtM)
ReDim dp(WidM,HgtM,1)

Dim As Single pan

Dim Shared As Integer               EveryNthFrame = 2

For i As Integer = 1 To 1 'seed
   mcenterx = Rnd
Next
mcenterx = 0
mcentery = 0

mfield_view = 0.5
FieldOfView(mcenterx,mcentery,TRUE,mfield_view, 0, 0.9, 2, 1, 1.2)
Splash(img(Flipper),,.5,TRUE)

Dim As Integer Paused
Dim As Double splash_time = .95, t = Timer

Do While 1

   If paused Then
   Else

      FramesPerSecond 0.5, TRUE

      LerpThrottle 0'EveryNthFrame
      Melt img(Flipper),img(1-Flipper)

      ScreenLock
      Blit img(Flipper)
      ? "FPS: "; fps_string
      ScreenUnLock
      
      If Timer > t Then
         Splash(img(Flipper), ,0.004,TRUE)
         t = Timer + splash_time
      EndIf
   EndIf
   
   pan = 0.12 * mfield_view

   If (ScreenEvent(@e)) Then
      if e.type = EVENT_KEY_PRESS Then
         Select Case e.scancode
            Case SC_ESCAPE
         Exit Do
            Case SC_G
         Splash(img(Flipper),,,TRUE)
            Case SC_1 To SC_9
         FieldOfView(mcenterx,mcentery,TRUE,mfield_view)
            Case SC_SPACE, SC_P
         Paused = Not Paused
            Case SC_CONTROL
         FF = 1 - FF
            Case SC_UP
         mcentery -= pan
         ViewCenter
            Case SC_DOWN
         mcentery += pan
         ViewCenter
            Case SC_LEFT
         mcenterx -= pan
         ViewCenter
            Case SC_RIGHT
         mcenterx += pan
         ViewCenter
            Case SC_PAGEUP
         mfield_view *= 0.8: ViewCenter
            Case SC_PAGEDOWN
         mfield_view /= 0.8: ViewCenter
         End Select
      End If
   End If

   Flipper = 1 - Flipper
   Sleep 20
Loop

img(1).Destroy
img(0).Destroy
Last edited by dafhi on Aug 08, 2016 3:14, edited 8 times in total.
dafhi
Posts: 1640
Joined: Jun 04, 2005 9:51

Re: sine fractals

Post by dafhi »

Feb 21 Update
Gonzo
Posts: 722
Joined: Dec 11, 2005 22:46

Re: sine fractals

Post by Gonzo »

looks nice, and continous.. nD functions must be continous =)
if you wanna talk further join #textella on EFnet irc network
Post Reply