Fractal Terrain Line

remi_meier · Post by **remi_meier** » Sat Dec 10, 2005 6:07 pm

Code updated For 5.20+

A small interface for a small 2D terrain line. Just4fun and perhaps some
games

There are two examples, one with collision and one with lemmings

Interface:

;-#################################### START OF INTERFACE ####################################

Interface iTERRAIN
  GenerateTerrain() ; berechnet Terrain
  GetTerrain() ; gibt Pointer auf Terrain-Array zurück
  SetTerrain(*Terrain, CountOfPoints) ; kopiert ein Terrain-Array in die Klasse
  SetCountOfPoints(Count) ; setzt, wieviele Punkte berechnet werden sollen
  GetCountOfPoints()
  SetZoomFactor(Factor.f) ; setzt einen Vergrösserungsfaktor
  GetZoomFactor.f()
  SetTransFactor(Factor.f) ; setzt einen Verschiebungsfaktor
  GetTransFactor.f()
  SetRandomSeed(Seed) ; setze Startwert für Terrain
  GetRandomSeed()
  SetPoint(Index, Value.f)
  GetPoint.f(Index)
EndInterface

Structure cTERRAIN_VTABLE
  GenerateTerrain.l
  GetTerrain.l
  SetTerrain.l
  SetCountOfPoints.l
  GetCountOfPoints.l
  SetZoomFactor.l
  GetZoomFactor.l
  SetTransFactor.l
  GetTransFactor.l
  SetRandomSeed.l
  GetRandomSeed.l
  SetPoint.l
  GetPoint.l
EndStructure

Structure cTERRAIN
  *VTable.cTERRAIN_VTABLE
  
  ; Data
  ZoomFactor.f
  TransFactor.f
  CountOfPoints.l
  pTerrain.l
  RndSeed.l
EndStructure


;- Hilfsprozeduren
Global terrain_mv.f, terrain_d.l, terrain_max.l, terrain_array.l
Global terrain_transl.f, terrain_zoom.f

Procedure terrain_Split(low.l, high.l)
  Protected m.l
  
  m = (high + low) / 2
  terrain_d = high - low
  If terrain_d <= 1
    ProcedureReturn 0
  EndIf
  
  terrain_mv = (PeekF(terrain_array + high * SizeOf(Float)) + PeekF(terrain_array + low * SizeOf(Float))) / 2.0
  
  PokeF(terrain_array + m * SizeOf(Float), terrain_mv - (Random(10000) / 10000.0 - terrain_transl) * terrain_zoom * terrain_d / Sqr(terrain_max))
  
  terrain_Split(m, high)
  terrain_Split(low, m)
EndProcedure

;- Methoden
Procedure terrain_GenerateTerrain(*this.cTERRAIN) ; berechnet Terrain
  Protected *mem
  
  *mem = ReAllocateMemory(*this\pTerrain, *this\CountOfPoints)
  If *mem
    *this\pTerrain = *mem
  Else
    ProcedureReturn #False
  EndIf
  
  ; Globale Variablen setzen
  terrain_mv = 0
  terrain_d = 0
  terrain_max = *this\CountOfPoints - 1
  terrain_array = *this\pTerrain
  terrain_transl = *this\TransFactor
  terrain_zoom = *this\ZoomFactor
  
  RandomSeed(*this\RndSeed)
  ; Aufruf:
  terrain_Split(0, *this\CountOfPoints - 1)
EndProcedure

Procedure.l terrain_GetTerrain(*this.cTERRAIN) ; gibt Pointer auf Terrain-Array zurück
  ProcedureReturn *this\pTerrain
EndProcedure

Procedure terrain_SetTerrain(*this.cTERRAIN, *Terrain, CountOfPoints.l) ; kopiert ein Terrain-Array in die Klasse
  Protected *mem
  
  *mem = ReAllocateMemory(*this\pTerrain, CountOfPoints * SizeOf(Float))
  If *mem
    *this\pTerrain = *mem
  Else
    ProcedureReturn #False
  EndIf
  
  CopyMemory(*Terrain, *this\pTerrain, CountOfPoints * SizeOf(Float))
EndProcedure

Procedure terrain_SetCountOfPoints(*this.cTERRAIN, Count.l) ; setzt, wieviele Punkte berechnet werden sollen
  *this\CountOfPoints = Count
EndProcedure

Procedure.l terrain_GetCountOfPoints(*this.cTERRAIN)
  ProcedureReturn *this\CountOfPoints
EndProcedure

Procedure terrain_SetZoomFactor(*this.cTERRAIN, Factor.f) ; setzt einen Vergrösserungsfaktor
  *this\ZoomFactor = Factor
EndProcedure

Procedure.f terrain_GetZoomFactor(*this.cTERRAIN)
  ProcedureReturn *this\ZoomFactor
EndProcedure

Procedure terrain_SetTransFactor(*this.cTERRAIN, Factor.f) ; setzt einen Verschiebungsfaktor
  *this\TransFactor = Factor
EndProcedure

Procedure.f terrain_GetTransFactor(*this.cTERRAIN)
  ProcedureReturn *this\TransFactor
EndProcedure

Procedure terrain_SetRandomSeed(*this.cTERRAIN, Seed.l)
  *this\RndSeed = Seed
EndProcedure

Procedure.l terrain_GetRandomSeed(*this.cTERRAIN)
  ProcedureReturn *this\RndSeed
EndProcedure

Procedure terrain_SetPoint(*this.cTERRAIN, Index.l, Value.f)
  PokeF(*this\pTerrain + Index * SizeOf(Float), Value)
EndProcedure

Procedure.f terrain_GetPoint(*this.cTERRAIN, Index.l)
  ProcedureReturn PeekF(*this\pTerrain + Index * SizeOf(Float))
EndProcedure


Procedure.l new_terrain()
  Protected *temp.cTERRAIN
  
  *temp = AllocateMemory(SizeOf(cTERRAIN))
  If *temp
    *temp\ZoomFactor = 200
    *temp\TransFactor = 0.5
    
    *temp\VTable = AllocateMemory(SizeOf(cTERRAIN_VTABLE))
    If *temp\VTable
      *temp\VTable\GenerateTerrain   = @terrain_GenerateTerrain()
      *temp\VTable\GetTerrain            = @terrain_GetTerrain()
      *temp\VTable\SetTerrain            = @terrain_SetTerrain()
      *temp\VTable\SetCountOfPoints   = @terrain_SetCountOfPoints()
      *temp\VTable\GetCountOfPoints   = @terrain_GetCountOfPoints()
      *temp\VTable\SetZoomFactor      = @terrain_SetZoomFactor()
      *temp\VTable\GetZoomFactor      = @terrain_GetZoomFactor()
      *temp\VTable\SetTransFactor      = @terrain_SetTransFactor()
      *temp\VTable\GetTransFactor      = @terrain_GetTransFactor()
      *temp\VTable\SetRandomSeed      = @terrain_SetRandomSeed()
      *temp\VTable\GetRandomSeed      = @terrain_GetRandomSeed()
      *temp\VTable\SetPoint               = @terrain_SetPoint()
      *temp\VTable\GetPoint               = @terrain_GetPoint()
    Else
      FreeMemory(*temp)
      *temp = 0
    EndIf
  EndIf
  
  ProcedureReturn *temp
EndProcedure

Procedure delete_terrain(*terrain.cTERRAIN)
  If *terrain
    If *terrain\pTerrain
      FreeMemory(*terrain\pTerrain)
    EndIf
    If *terrain\VTable
      FreeMemory(*terrain\VTable)
    EndIf
    FreeMemory(*terrain)
  EndIf
EndProcedure

;-#################################### END OF INTERFACE ####################################

Collision:

Code: Select all

Structure XY
  x.f
  y.f
EndStructure

Procedure.f LineLineCol(*P.XY, *r.XY, *A.XY, *B.XY, *OUT.XY)
  Protected t.f, s.f
  Protected AB.XY
  
  s = *A\x * *r\y - *A\y * *r\x
  t = (s - *P\x * *r\y + *P\y * *r\x) / (s - *B\x * *r\y + *B\y * *r\x)
  
  AB\x = *B\x - *A\x
  AB\y = *B\y - *A\y
  
  If t >= -0.0001 And t <= 1.0001
    *OUT\x = *A\x + t * AB\x
    *OUT\y = *A\y + t * AB\y
    
    ProcedureReturn Pow(*OUT\x - *P\x, 2) + Pow(*OUT\y - *P\y, 2)
  EndIf
  
  ProcedureReturn 99999999.0
EndProcedure

Procedure.l LineCollideArray(terrain.iTERRAIN, *Start.XY, *Dir.XY, *Out.XY)
  Protected i.l, shortestDis.f, t.f
  Protected A.XY, B.XY, Out2.XY, max.l
  
  max = terrain\GetCountOfPoints()
  
  shortestDis = 99999999.0
  For i = 1 To max - 1
    A\y = 1.0 + terrain\GetPoint(i - 1) + 250.0
    A\x = 1.0 * (i - 1) / max * 500
    B\y = 1.0 + terrain\GetPoint(i) + 250.0
    B\x = 1.0 * i / max * 500
    
    t = LineLineCol(*Start, *Dir, @A, @B, @Out2)
    If t < shortestDis
      shortestDis = t
      *Out\x = Out2\x
      *Out\y = Out2\y
    EndIf
  Next
EndProcedure


terr.iTERRAIN = new_terrain()
terr\SetCountOfPoints(100)
terr\SetZoomFactor(50)
;terr\SetRandomSeed(30)
terr\GenerateTerrain()



CreateImage(0, 500, 500)

OpenWindow(0, 200, 200, 500, 500, "Drawing", #PB_Window_SystemMenu|#PB_Window_ScreenCentered)

ImageGadget(1, 0, 0, 500, 500, ImageID(0))





SetGadgetState(1, ImageID(0))
Repeat
  
  hdc = StartDrawing(ImageOutput(0))
  Box(0,0, 500,500, 0)
  
  px.l = terr\GetCountOfPoints()
  For z = 1 To px - 1
    LineXY(1.0 * (z - 1) / px * 500, terr\GetPoint(z - 1) + 250, 1.0 * z / px * 500, terr\GetPoint(z) + 250, $FF)
  Next
  
  P.XY
  P\x = 250
  P\y = 0
  Dir.XY
  Dir\x = WindowMouseX(0) - 250
  Dir\y = WindowMouseY(0)
  Out.XY
  LineCollideArray(terr, @P, @Dir, @Out)
  Circle(Out\x, Out\y, 10, $FF00)
  Line(P\x, P\y, Dir\x, Dir\y, $FF0000)
  StopDrawing()
  SetGadgetState(1, ImageID(0))
  
  
  Delay(10)
Until WindowEvent() = #PB_Event_CloseWindow

Lemmings:

Code: Select all

Structure XY
  x.f
  y.f
EndStructure


Procedure.l GetPointAndVector(terrain.iTERRAIN, x.f, *P.XY, *VEC.XY)
  Protected max.l, index.l
  Protected A.XY, B.XY, AB.XY, len.f
  
  max = terrain\GetCountOfPoints()
  
  index = Int(x / 500.0 * max)
  If index >= max - 1
    ProcedureReturn
  EndIf
  
  A\x = 1.0 * index / max * 500
  A\y = 1.0 * terrain\GetPoint(index) + 250.0
  B\x = 1.0 * (index + 1) / max * 500
  B\y = 1.0 * terrain\GetPoint(index + 1) + 250.0
  AB\x = B\x - A\x
  AB\y = B\y - A\y
  
  
  *P\x = x
  *P\y = A\y + (x - A\x) * AB\y / AB\x
  
  len = Sqr(AB\x * AB\x + AB\y * AB\y)
  *VEC\x = AB\y / len * 10
  *VEC\y = -AB\x / len * 10
  
EndProcedure


terr.iTERRAIN = new_terrain()
terr\SetCountOfPoints(300)
terr\SetZoomFactor(30)
terr\SetRandomSeed(30)
terr\GenerateTerrain()



CreateImage(0, 500, 500)

OpenWindow(0, 200, 200, 500, 500, "Drawing", #PB_Window_SystemMenu|#PB_Window_ScreenCentered)

ImageGadget(1, 0, 0, 500, 500, ImageID(0))





SetGadgetState(1, ImageID(0))

#LEMMINGS = 20
Dim lemminge.f(#LEMMINGS)
For x = 0 To #LEMMINGS
  lemminge(x) = x * 10
Next

Repeat
  ;       ImageID(0)
  hdc = StartDrawing(ImageOutput(0))
  Box(0,0, 500,500, 0)
  
  px.l = terr\GetCountOfPoints()
  For z = 1 To px - 1
    LineXY(1.0 * (z - 1) / px * 500, terr\GetPoint(z - 1) + 250, 1.0 * z / px * 500, terr\GetPoint(z) + 250, $FF)
  Next
  
  For x = 0 To #LEMMINGS
    lemminge(x) + 0.5
    If lemminge(x) > 500
      lemminge(x) = 0
    EndIf
    P.XY
    Dir.XY
    GetPointAndVector(terr, lemminge(x), @P, @Dir)
    Circle(P\x, P\y, 1, $FF00)
    Line(P\x, P\y, Dir\x, Dir\y, $FF0000)
  Next
  StopDrawing()
  SetGadgetState(1, ImageID(0))
  
  
  Delay(20)
Until WindowEvent() = #PB_Event_CloseWindow

greetz
Remi

EDIT: Bug corrected

va!n · Post by **va!n** » Sun Dec 11, 2005 7:24 pm

very nice one! keep on your nice work

Comtois · Post by **Comtois** » Sun Dec 11, 2005 8:11 pm

yes great work