It is currently Thu Apr 18, 2019 10:03 pm

All times are UTC + 1 hour




Post new topic Reply to topic  [ 3 posts ] 
Author Message
 Post subject: Landscape v2
PostPosted: Mon Feb 11, 2019 11:43 am 
Offline
User
User

Joined: Thu Jul 09, 2015 9:07 am
Posts: 64
Image
Hi,

the 2nd issue of a series of codes whose purpose is to make natural decors
for v2 we have unlimited terrain (in fact a 1024*1024 looped matrix)
I added the possibility of flying to better enjoy it.
otherwise, no difference (I didn't even bother to change the screenshot...)

for V3 we will have the management of the LOD (level of distance)
meshes are created in several versions with varying levels of detail.
Nearby entities are displayed with the maximum level of detail,
the further away the entities are and the lower their level of detail

Code:
; ----------------------------------------------------------------------------------------------------------
;   Paysage V2 - pf Shadoko - 2018
; ----------------------------------------------------------------------------------------------------------

;{ ============================= biblio
Structure Vector2
  x.f
  y.f
EndStructure

Structure Vector3
  x.f
  y.f
  z.f
EndStructure

Macro vec3d(v,vx,vy,vz)
  v\x=vx
  v\y=vy
  v\z=vz
EndMacro

Procedure.f Max(v1.f,v2.f)
  If v1>v2:ProcedureReturn v1:Else:ProcedureReturn v2:EndIf
EndProcedure

Procedure.f Min(v1.f,v2.f)
  If v1<v2:ProcedureReturn v1:Else:ProcedureReturn v2:EndIf
EndProcedure

Procedure.f limite(V.f, i.f, s.f)
  If V < i :v=i:EndIf
  If V > s :v=s:EndIf
  ProcedureReturn V
EndProcedure

Procedure.f iif(cond.b,voui.f,vnon.f)
  If cond:ProcedureReturn voui:Else:ProcedureReturn vnon:EndIf
EndProcedure

Macro vec2d(v,vx,vy)
  v\x=vx
  v\y=vy
EndMacro

Procedure.f interpolarray2d(Array tt.w(2),x.f,y.f)
  Protected.l i0, j0,i1,j1,dx1,dy1
  Protected.f dx, dy
  dx1=ArraySize(tt(),1)
  dy1=ArraySize(tt(),2)
  i0 = Int(X) & dx1:i1=(i0+1) & dx1: dx = X - Int(x)
  j0 = Int(Y) & dy1:j1=(j0+1) & dy1: dy = Y - Int(y)
  ProcedureReturn (((1 - dx) * tt(j0,i0) + dx * tt(j0,i1)) * (1 - dy) + ((1 - dx) * tt(j1,i0) + dx * tt(j1,i1)) * dy)
EndProcedure

Procedure.f POM(v.f)
  ProcedureReturn (Random(v*1000)-v*500)/500
EndProcedure

Procedure Split(Array t.s(1),l.s,sep.s=",",nmax=100)
  Protected ap.l,p.l,n,ls
  Dim t(nmax)
  ls=Len(sep)
  l+sep
  p=1-ls
  Repeat
    ap=p+ls:p=FindString(l,sep,ap)
    If p=0:Break:EndIf
    n+1
    t(n)= Mid(l,ap,p-ap)
  ForEver
  ReDim t(n)
EndProcedure

Procedure string2vector2(Array s.vector2(1),txt.s)
  Dim tt.s(0)
  Dim t.s(0)
  Protected i,n
 
  split(tt(),txt,"/",100)
  n=ArraySize(tt())
  Dim s(n-1)
  For i=1 To n
    split(t(),tt(i)+",0",",")
    With s(i-1)
      \x=ValF(t(1))
      \y=ValF(t(2))
    EndWith
  Next
EndProcedure

Procedure CoRBinv(c.l)
  ProcedureReturn  RGBA(Blue(c),Green(c),Red(c),Alpha(c))
EndProcedure

Procedure ColorBlend(color1.l, color2.l, blend.f)
  Protected r.w,g.w,b.w,a.w
  r=  Red(color1) + (Red(color2)     - Red(color1)) * blend
  g=Green(color1) + (Green(color2) - Green(color1)) * blend
  b= Blue(color1) + (Blue(color2) -   Blue(color1)) * blend
  a=Alpha(color1) + (Alpha(color2) - Alpha(color1)) * blend
  ProcedureReturn  RGBA(r,g,b,a)
EndProcedure

Procedure Finterpol(Array F.f(1),t.s,rx.f=1,ry.f=1,oy.f=0)
  Protected.l i,j,n,c,ac
  Protected.f y,dx,dy,p
  Protected Dim s.vector2(0)
  string2vector2(s(),t)
  n=ArraySize(s())
  For i=0 To n
    s(i)\x*rx
    s(i)\y*ry+oy
  Next 
  Dim f(Int(s(n)\x))
  For j=0 To n-1
    y=s(j)\y
    dx=s(j+1)\x-s(j)\x
    dy=s(j+1)\y-s(j)\y
    p=dy/dx
    ac=c
    While c<=s(j+1)\x
      f(c)=y+p*(c-ac):c+1
    Wend
  Next
EndProcedure

Procedure t2norme(Array t.w(2),dmin.w,dmax.w,profil.s="")
  Protected smin.w,smax.w,dx1,dy1,i,j,sr,dr
  If profil="":profil="0,0/1,1":EndIf
  dy1 = ArraySize(t(), 1)
  dx1 = ArraySize(t(), 2)
  smax = -32768
  smin =  32767
  For j=0 To dy1
    For i=0 To dx1
      If t(j,i)>smax : smax=t(j,i): EndIf
      If t(j,i)<smin : smin=t(j,i): EndIf
    Next
  Next
  sr=smax-smin
  dr=dmax-dmin
 
  Protected Dim conv.f(sr)
  Finterpol(conv(),profil,sr,dr,dmin)
 
  For j=0 To dy1
    For i=0 To dx1
      t(j,i)=conv(t(j,i)-smin)
    Next
  Next
EndProcedure

Procedure Tmodulo(Array T(1), max, marge)
  Protected i,d=max-marge/2
  Dim T(max + 2*marge): For i = 0 To max + 2*marge: T(i) = (i+d) % (max+1): Next
EndProcedure

Procedure Tlimite(Array T(1), max, marge)
  Protected i
  Dim T(max + 2*marge): For i = 0 To max + 2*marge: T(i) = limite(i-1-marge/2, 0, max): Next
EndProcedure

Procedure lisser2D(Array s.w(2),di.w, dj.w,pass=1,loop=1)
  If di=0 And dj=0:ProcedureReturn:EndIf
  Protected i,j,k,dii,djj,dx,dy,dij,tx
  dx = ArraySize(s(), 2):di=min(di,dx)
  dy = ArraySize(s(), 1):dj=min(dj,dy)
  Dim d.w(dy,dx)
  dii=di+1
  djj=dj+1
  dij = dii * djj
  Dim lx(0)
  Dim ly(0)
  If loop
    Tmodulo (lx(), dx, di+1)
    Tmodulo (ly(), dy, dj+1)
  Else
    Tlimite(lx(), dx, di+1)
    Tlimite(ly(), dy, dj+1)
  EndIf 
  For k=1 To pass
    Dim ty.l(dx)
    For j = 0 To djj - 1: For i = 0 To dx: ty(i) + s(ly(j),i): Next: Next   
    For j = 0 To dy
      For i = 0 To dx: ty(i) + s(ly(djj+j),i) - s(ly(j),i): Next
      tx=0:For i = 0 To dii-1: tx+ty(lx(i)): Next
      For i = 0 To dx: tx + ty(lx(dii+i)) - ty(lx(i) ): d(j,i) = tx / dij: Next
    Next
    CopyArray(d(),s())
  Next
EndProcedure

Procedure Embos(Array s.w(2), px.w=0, py.w=0)
  Protected i,j,dx,dy
  px=1<<Int(Abs(px))*Sign(px)
  py=1<<Int(Abs(py))*Sign(py)
 
  Macro gra(j0,i0,j1,i1)
    t(j0,i0)=Abs(s(j0,i0)-s(j0,i1)+px)+Abs(s(j0,i0)-s(j1,i0)+py)
  EndMacro
  dy = ArraySize(s(), 1)
  dx = ArraySize(s(), 2)
  Dim T.w(dy,dx)
  For j=0 To dy-1
    For i=0 To dx-1
      gra(j,i,j+1,i+1)
    Next
    gra(j,dx,j+1,0)
  Next
  For i = 0 To dx-1
    gra(dy,i,0,i+1)
  Next
  gra(dy,dx,0,0)
  CopyArray(t(),s())
EndProcedure

Procedure heightmap(Array t.w(2),rnd, dy.w, dx.w, Re.w)
  Protected i,j,ii,jj,n,d,dd,dx1=dx-1,dy1=dy-1,l,R, rr,dec
 
  RandomSeed(rnd)
  n = 1<<re
  dd=min(dx,dy) / n: If dd<1:dd=1:EndIf
  Dim t.w(dy-1, dx-1)
  rr = $1fff:r=rr>>1
  For jj = 0 To dy/dd - 1:j=jj*dd: For ii = 0 To dx/dd - 1:i=ii*dd: t(j,i) = Random(rr) - R: Next: Next
  l = dd
  While dd > 1
    d = dd / 2
    For jj = 0 To dy/dd - 1  :j=jj*dd+d
      For ii = 0 To dx/dd - 1:i=ii*dd+d
        t(j,i) = (t((j - d) & dy1,(i - d) & dx1) + t((j - d) & dy1,(i + d) & dx1) + t((j + d) & dy1,(i + d) & dx1) + t((j + d) & dy1,(i - d) & dx1)) / 4 + Random(rr) - R
      Next
    Next
    For jj = 0 To dy/d - 1  :j=jj*d:dec=1- jj & 1
      For ii = 0 To dx/dd - 1:i=ii*dd+dec*d
        t(j,i) = (t(j,(i - d) & dx1) + t(j,(i + d) & dx1) + t((j - d) & dy1,i) + t((j + d) & dy1,i)) / 4 + Random(rr) - R
      Next
    Next
    l/2
    dd/2
    r/2:rr/2
  Wend
EndProcedure
;}

;######################################################################################################

Global lumnb,lum,ex,ey

Global Dim h.w(0,0)
Global Dim g.w(0,0)

#tt=64:#tt1=#tt-1:#tt2=#tt/2
#di=512*2:#di1=#di-1:#dit=#di/#tt:#dit1=#dit-1
#dj=512*2:#dj1=#dj-1:#djt=#dj/#tt:#djt1=#djt-1

Enumeration objet:#ciel=10:#eau:#terrain=100:EndEnumeration

Procedure terrain_tile(Array h.w(2),Array g.w(2),pi,pj,n)
  Protected i,j,ii,jj, h,g, c
  Dim t.PB_MeshVertex(#tt,#tt)
 
  For j=0 To #tt:jj=pj+j
    For i=0 To #tt:ii=pi+i
      h=h(ii & #di1,jj & #dj1)
      g=g(ii & #di1,jj & #dj1)
      With t(i,j)
        \x=(i-#tt2)
        \y=h/16
        \z=(j-#tt2)
        \u=i/8
        \v=j/8
        color=$ffffff
        If h<700+pom(100)
          If g<40:color=iif(Random(1),$00cc22,$44cc88) :Else:color=iif(Random(8),$88aaaa,$aaaa88):EndIf
        EndIf
        If h<20:color=$00ccff:EndIf
        If h<-20:color=$000000:EndIf
        \color=color
      EndWith
    Next
  Next
 
  CreateDataMesh(n,t())
  NormalizeMesh(n)
EndProcedure

Procedure terrain(liss=2)
  Protected i,j,k,n,is,js
 
  heightmap(h(),5,#di,#dj,4)
  lisser2d(h(),liss,liss,1)
  ;t2norme(h(),-10,90,"0,0/0.4,0.2/0.7,0.4/0.7,1/1,1")
  t2norme(h(),-200,800,"0,0/0.4,0.2/0.7,0.4/1,1")
  ;t2norme(h(),-100,1000,"0,0/0.3,0.1/0.6,0.2/0.7,0.5/1,1")
  CopyArray(h(),g())
  embos(g(),0,0)
 
  For j=0 To #djt1
    For i=0 To #dit1
      terrain_tile(h(),g(),i*#tt,j*#tt,#terrain+j*#dit+i)
    Next
  Next
EndProcedure

Procedure rendertile()
  Static api,pi=1000,  apj,pj=1000,  i0,i1,  j0,j1,  e,m,cpt
  Protected i,j
  api=pi:pi=(CameraX(0)-#di/2)/#tt:If pi<api:i0=pi:i1=api-1:Else:i0=api+1+#dit1:i1=pi+#dit1:EndIf
  apj=pj:pj=(CameraZ(0)-#dj/2)/#tt:If pj<apj:j0=pj:j1=apj-1:Else:j0=apj+1+#djt1:j1=pj+#djt1:EndIf
  cpt=0
  For j=pj To pj+#djt1
    For i=pi To pi+#dit1
      If (i>=i0 And i<=i1) Or (j>=j0 And j<=j1)
        e=#terrain+(j & #djt1)*#dit+(i & #dit1)
        m=#terrain+(j & #djt1)*#dit+(i & #dit1)
        CreateEntity(e,MeshID(m),MaterialID(1),i*#tt+#tt2,0,j*#tt+#tt2)
        cpt+1
      EndIf
    Next
  Next
  MoveEntity(#eau,pi*#tt+#di/2,0,(pj+#djt/2)*#tt,#PB_Absolute)
EndProcedure

Procedure affiche3d()
  Static.f MouseX,Mousey,keyx,keyy,keyz, ysol,y,  fly=1,fdf,ymin=-1000
  Protected i,transit=200
 
  Repeat
    ExamineMouse()
    MouseX = -MouseDeltaX() *  0.05
    MouseY = -MouseDeltaY() *  0.05
    ExamineKeyboard()
    keyx=(-Bool(KeyboardPushed(#PB_Key_Left))+Bool(KeyboardPushed(#PB_Key_Right)))*0.1
    keyz=(-Bool(KeyboardPushed(#PB_Key_Down))+Bool(KeyboardPushed(#PB_Key_Up   )))*0.1+MouseWheel()*10
    If KeyboardReleased(#PB_Key_F11):fly=1-fly:EndIf
    If KeyboardReleased(#PB_Key_F12):fdf=1-fdf:If fdf:CameraRenderMode(0,#PB_Camera_Wireframe):Else:CameraRenderMode(0,#PB_Camera_Textured):EndIf:EndIf
    RotateCamera(0, MouseY, MouseX, 0, #PB_Relative)
    MoveCamera  (0, KeyX, 0, -keyz-fly*0.1)
    ysol=max(0.2,interpolarray2d(h(), CameraZ(0)+#dj*100, CameraX(0)+#di*100)/16+1.6):If fly:y=max(ysol,CameraY(0)):Else:y=ysol:EndIf
    MoveCamera(0,CameraX(0),y,CameraZ(0),#PB_Absolute)
    rendertile()
    CameraReflection(1,0,EntityID(#eau))   
    RenderWorld()
    DisplayTransparentSprite(0,8,8)
    FlipBuffers()
  Until KeyboardPushed(#PB_Key_Escape)
EndProcedure

Procedure menu()
  Protected p=4
  Macro DT(t1,t2)
    DrawText(8,p,t1)
    DrawText(100,p,t2)
    p+22
  EndMacro
  CreateSprite(0,220,160,#PB_Sprite_AlphaBlending)
  StartDrawing(SpriteOutput(0))
  DrawingMode(#PB_2DDrawing_AllChannels)
  DrawingFont(FontID(0))
  Box(0,0,220,160,$44000000)
  DrawingMode(#PB_2DDrawing_AllChannels|#PB_2DDrawing_Outlined)
  Box(0,0,220,160,$ffffffff)
  BackColor($44000000)
  FrontColor($ffffffff)
  dt("Moving :","")
  dt("Arrow keys + Mouse","")
  dt("","")
  dt("Controls :","")
  dt("[F11]","Fly / Walk")
  dt("[F12]","Wireframe")
  dt("[Esc]","Quit")
  StopDrawing()
EndProcedure

Procedure main()
  Protected i,r.f=1
  ExamineDesktops()
  ex=DesktopWidth(0)*r
  ey=DesktopHeight(0)*r
 
  InitKeyboard():InitMouse():InitEngine3D():InitSprite()
  ;OpenWindow(0,0,0,ex,ey,"",#PB_Window_BorderLess|#PB_Window_ScreenCentered):OpenWindowedScreen(WindowID(0), 0, 0, WindowWidth(0),WindowHeight(0))
  OpenScreen(ex,ey,32,"")
  LoadFont(0,"arial",12)
  menu()
  ;-------------------- scene
  CreateLight(0, $777777, 10000, 10000, 10000)
  AmbientColor($777777)
  CreateCamera(0, 0, 0, 100, 100)
  CameraLookAt(0, 0, 0, 1)
  Add3DArchive(#PB_Compiler_Home + "examples/3d/Data/Textures", #PB_3DArchive_FileSystem)
  Parse3DScripts()
  Fog($ff8888,200,0,800)
 
  ;terrain
  LoadTexture(1,"dirt.jpg") 
  LoadTexture(#ciel,"clouds.jpg")
  CreateMaterial(1,TextureID(1));:MaterialCullingMode(1,#PB_Material_NoCulling)
  SetMaterialColor(1, #PB_Material_AmbientColor,-1)
  terrain()
  ;AddMaterialLayer(1,TextureID(1),#PB_Material_Modulate):ScaleMaterial(1,0.3,0.3,1)
  ;MaterialBlendingMode(1,
 
  ;eau
  CreateCamera(1,0,0,100,100) 
  CreateRenderTexture(#eau,CameraID(1),ex/1,ey/1)
  CreateMaterial(#eau,TextureID(#eau))
  SetMaterialAttribute(#eau,#PB_Material_ProjectiveTexturing,1)
  CreateTexture(#eau+1,4,4):StartDrawing(TextureOutput(#eau+1)):DrawingMode(#PB_2DDrawing_AllChannels):Box(0,0,4,4,$bbffccaa):StopDrawing()
  AddMaterialLayer(#eau,TextureID(#eau+1),#PB_Material_Modulate)
  MaterialBlendingMode(#eau,#PB_Material_AlphaBlend)
  CreatePlane(#eau,#di,#dj,16,16,1,1)
  CreateEntity(#eau,MeshID(#eau),MaterialID(#eau))
 
  ;ciel
  CameraBackColor(0,$ff8888):CameraRange(0,0.1,10000)
  ;  texture(ciel,256,256,0,0,0,-1000,"0,$ff0000/1,$ffffff")
  CreateMaterial(#ciel,TextureID(#ciel))
  SetMaterialColor(#ciel,#PB_Material_SelfIlluminationColor,$ffffff):MaterialCullingMode(#ciel, #PB_Material_AntiClockWiseCull)
  CreatePlane(#ciel,10000,10000,1,1,64,64):  CreateEntity(#ciel,MeshID(#ciel),MaterialID(#ciel),0,200,0)
 
  affiche3d()
EndProcedure

main()


Top
 Profile  
Reply with quote  
 Post subject: Re: Landscape v2
PostPosted: Mon Feb 11, 2019 12:20 pm 
Offline
Addict
Addict

Joined: Mon Feb 16, 2015 2:49 pm
Posts: 1885
Awesome! :shock:


Top
 Profile  
Reply with quote  
 Post subject: Re: Landscape v2
PostPosted: Mon Feb 11, 2019 9:32 pm 
Offline
Addict
Addict
User avatar

Joined: Wed Jun 11, 2003 9:33 pm
Posts: 4548
Location: Spa, relaxing and thinking, and learning...
Nice planet!
:)

_________________
http://www.zeitgeistmovie.com

While world=business:world+mafia:Wend
While (world==business) {world+=mafia}


Top
 Profile  
Reply with quote  
Display posts from previous:  Sort by  
Post new topic Reply to topic  [ 3 posts ] 

All times are UTC + 1 hour


Who is online

Users browsing this forum: No registered users and 2 guests


You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum

Search for:
Jump to:  

 


Powered by phpBB © 2008 phpBB Group
subSilver+ theme by Canver Software, sponsor Sanal Modifiye