Algorithme de Perlin

Partagez votre expérience de PureBasic avec les autres utilisateurs.
Répondre
comtois
Messages : 5186
Inscription : mer. 21/janv./2004 17:48
Contact :
Contacter comtois

Algorithme de Perlin

Message par comtois »

J'ai adapté ce codeà PureBasic, il permet d'obtenir ce genre d'image
Image

C'est utile pour créer des textures, ou des terrains.

Code : Tout sélectionner

#Taille = 256
CreateImage(0,#taille,#Taille)
OpenWindow(0,0,0,#Taille,#Taille,"Perlin")
If CreateGadgetList(WindowID(0))
  ImageGadget(0,0,0,#taille,#taille,ImageID(0))
EndIf  

Structure s_Colonne
  y.l[#Taille]
EndStructure

Structure s_Calque
  x.s_Colonne[#Taille]
  persistance.f
EndStructure

Declare generer_calque(frequence, octaves, persistance.f, liss,*c.s_Calque)
Declare interpolate(y1, y2, n, delta)
Declare valeur_interpolee(i, j, frequence, *r.s_Calque)
Declare enregistrer_bmp(*c.s_Calque, filename.s)

Procedure init_calque(p.f)
    *s.s_Calque = AllocateMemory(SizeOf(s_calque))
    If *s=0
        MessageRequester("Oups!","erreur d'alloc",#PB_MessageRequester_Ok)
        ProcedureReturn #Null
    EndIf
    *s\persistance = p
    ProcedureReturn *s
EndProcedure

Procedure generer_calque(frequence, octaves, persistance.f, liss,*c.s_Calque)
    ; itératif
    Define i,j,n,f_courante
    Define x,y,k,l
    Define a
    Define.f pas, sum_persistances,persistance_courante
    
    pas = #taille/frequence
    persistance_courante = persistance
   
    ; calque aléatoire
    Define.s_Calque *random
    *random = init_calque(1)
    For i=0 To #taille-1
        For j=0 To #taille-1
            *random\x[i]\y[j]=Random(255)
        Next j
    Next i    
    enregistrer_bmp(*random, "alea.bmp")
    ; calques de travail
    Dim *mes_calques.s_Calque(octaves-1) 
    For  i=0 To octaves-1
        *mes_calques(i)=init_calque(persistance_courante)
        persistance_courante * persistance
    Next i

    f_courante = frequence

    ; remplissage de calque
    For n=0 To octaves-1
        For i=0 To #taille-1
            For j=0 To #taille-1
                a = valeur_interpolee(i, j, f_courante, *random)
                *mes_calques(n)\x[i]\y[j]=a
            Next j
        Next i    
        f_courante * frequence
    Next n

    sum_persistances = 0
    For i=0 To octaves-1
        sum_persistances + *mes_calques(i)\persistance
    Next i 
    ; ajout des calques successifs
    For i=0 To #taille-1
        For j=0 To #taille-1
            For n=0 To octaves-1
                *c\x[i]\y[j] + *mes_calques(n)\x[i]\y[j] * *mes_calques(n)\persistance
            Next n 
            ;normalisation
            *c\x[i]\y[j] = *c\x[i]\y[j] / sum_persistances
        Next j
    Next i 

    ;lissage
    Define *lissage.s_Calque
    *lissage = init_calque(0)
    For x=0 To #taille-1
        For y=0 To #taille-1
            a=0
            n=0
            For k=x-liss To x+liss
                For l=y-liss To y+liss
                    If ((k>=0) And (k<#taille) And (l>=0) And (l<#taille)) 
                        n + 1
                        a + *c\x[k]\y[l]
                    EndIf
                Next l
            Next k        
            *lissage\x[x]\y[y] = a/n
        Next y
    Next x 
    enregistrer_bmp(*lissage, "lisse.bmp")
EndProcedure

Procedure interpolate(y1, y2, n, delta)

    ; interpolation non linéaire
    If n=0
        ProcedureReturn y1
    EndIf
    If n=1
        ProcedureReturn y2
    EndIf 
    a.f = delta/n

    fac1.f = 3*Pow(1-a, 2) - 2*Pow(1-a,3)
    fac2.f = 3*Pow(a, 2) - 2*Pow(a, 3)

    ProcedureReturn y1*fac1 + y2*fac2
EndProcedure


Procedure valeur_interpolee(i, j, frequence, *r.s_Calque)
    ; valeurs des bornes
    Define borne1x, borne1y, borne2x, borne2y, q
    Define.l pas
    
    pas = #taille/frequence
    If pas = 0 : pas = 1 : EndIf

    q = i/pas
    borne1x = q*pas
    borne2x = (q+1)*pas

    If borne2x >= #taille
      borne2x = #taille-1
    EndIf     

    q = j/pas
    borne1y = q*pas
    borne2y = (q+1)*pas

    If borne2y >= #taille
      borne2y = #taille-1
    EndIf    

    Define b00,b01,b10,b11
    b00 = *r\x[borne1x]\y[borne1y]
    b01 = *r\x[borne1x]\y[borne2y]
    b10 = *r\x[borne2x]\y[borne1y]
    b11 = *r\x[borne2x]\y[borne2y]

    v1 = interpolate(b00, b01, borne2y-borne1y, j-borne1y)
    v2 = interpolate(b10, b11, borne2y-borne1y, j-borne1y)
    fin = interpolate(v1, v2, borne2x-borne1x , i-borne1x)
    
    ProcedureReturn fin
EndProcedure

Procedure aleatoire(a.f)
  ProcedureReturn Random(256) 
EndProcedure

Procedure enregistrer_bmp(*c.s_Calque, filename.s)
  CreateImage(0,#taille, #taille, 32)
  If StartDrawing(ImageOutput(0))
      For i=0 To #taille-1
        For j=0 To #taille-1
          Plot(i,j,RGB(*c\x[i]\y[j],*c\x[i]\y[j],*c\x[i]\y[j]))
        Next j
      Next i    
    StopDrawing()
    SaveImage(0,filename)
  EndIf  
EndProcedure

Procedure main()

  ;valeurs d'entrée
	octaves=3
	frequence=5
	persistance.f=0.3
  lissage = 9

  ;création de calque
  Define.s_Calque *s
  *s = init_calque(persistance)
  generer_calque(frequence, octaves, persistance,lissage, *s)
  ;enregistrer_bmp(*s, "resultat.bmp")
EndProcedure

main()

SetGadgetState(0,ImageID(0))
SetClipboardImage(0)
Repeat
  EventID = WaitWindowEvent()

  If EventID = #PB_Event_CloseWindow  
    Quit = 1
  EndIf

Until Quit = 1
http://purebasic.developpez.com/
Je ne réponds à aucune question technique en PV, utilisez le forum, il est fait pour ça, et la réponse peut profiter à tous.
Haut
tmyke
Messages : 1554
Inscription : lun. 24/juil./2006 6:44
Localisation : vosges (France) 47°54'39.06"N 6°20'06.39"E

Message par tmyke »

Très bon code. Je vais voir pour faire un petit code qui dans la foulé fait une
representation 3D du relief ainsi créé... :lol:
Force et sagesse...
Haut
minirop
Messages : 321
Inscription : mer. 02/août/2006 21:06

Message par minirop »

tmyke a écrit :Très bon code. Je vais voir pour faire un petit code qui dans la foulé fait une
representation 3D du relief ainsi créé... :lol:
heightmap ? (y'a pas çà dans DM3D ?)
Haut
tmyke
Messages : 1554
Inscription : lun. 24/juil./2006 6:44
Localisation : vosges (France) 47°54'39.06"N 6°20'06.39"E

Message par tmyke »

Oui, bien sur, et 32 bits en plus ... :wink:
Force et sagesse...
Haut
tmyke
Messages : 1554
Inscription : lun. 24/juil./2006 6:44
Localisation : vosges (France) 47°54'39.06"N 6°20'06.39"E

Message par tmyke »

Voici donc en quelques ligne de plus, une petite partie 3D ajoutée.

Code : Tout sélectionner

; Fichiers Include 
IncludePath "Include\"  :  IncludeFile "dreamotion3d.pbi"
Global *camera.CEntity


#Taille = 256
CreateImage(0,#taille,#Taille)
OpenWindow(0,0,0,#Taille,#Taille,"Perlin")
If CreateGadgetList(WindowID(0))
  ImageGadget(0,0,0,#taille,#taille,ImageID(0))
EndIf 

Structure s_Colonne
  y.l[#Taille]
EndStructure

Structure s_Calque
  x.s_Colonne[#Taille]
  persistance.f
EndStructure

Declare generer_calque(frequence, octaves, persistance.f, liss,*c.s_Calque)
Declare interpolate(y1, y2, n, delta)
Declare valeur_interpolee(i, j, frequence, *r.s_Calque)
Declare enregistrer_bmp(*c.s_Calque, filename.s)

Procedure init_calque(p.f)
    *s.s_Calque = AllocateMemory(SizeOf(s_calque))
    If *s=0
        MessageRequester("Oups!","erreur d'alloc",#PB_MessageRequester_Ok)
        ProcedureReturn #Null
    EndIf
    *s\persistance = p
    ProcedureReturn *s
EndProcedure

Procedure generer_calque(frequence, octaves, persistance.f, liss,*c.s_Calque)
    ; itératif
    Define i,j,n,f_courante
    Define x,y,k,l
    Define a
    Define.f pas, sum_persistances,persistance_courante
   
    pas = #taille/frequence
    persistance_courante = persistance
   
    ; calque aléatoire
    Define.s_Calque *random
    *random = init_calque(1)
    For i=0 To #taille-1
        For j=0 To #taille-1
            *random\x[i]\y[j]=Random(255)
        Next j
    Next i   
    enregistrer_bmp(*random, "alea.bmp")
    ; calques de travail
    Dim *mes_calques.s_Calque(octaves-1)
    For  i=0 To octaves-1
        *mes_calques(i)=init_calque(persistance_courante)
        persistance_courante * persistance
    Next i

    f_courante = frequence

    ; remplissage de calque
    For n=0 To octaves-1
        For i=0 To #taille-1
            For j=0 To #taille-1
                a = valeur_interpolee(i, j, f_courante, *random)
                *mes_calques(n)\x[i]\y[j]=a
            Next j
        Next i   
        f_courante * frequence
    Next n

    sum_persistances = 0
    For i=0 To octaves-1
        sum_persistances + *mes_calques(i)\persistance
    Next i
    ; ajout des calques successifs
    For i=0 To #taille-1
        For j=0 To #taille-1
            For n=0 To octaves-1
                *c\x[i]\y[j] + *mes_calques(n)\x[i]\y[j] * *mes_calques(n)\persistance
            Next n
            ;normalisation
            *c\x[i]\y[j] = *c\x[i]\y[j] / sum_persistances
        Next j
    Next i

    ;lissage
    Define *lissage.s_Calque
    *lissage = init_calque(0)
    For x=0 To #taille-1
        For y=0 To #taille-1
            a=0
            n=0
            For k=x-liss To x+liss
                For l=y-liss To y+liss
                    If ((k>=0) And (k<#taille) And (l>=0) And (l<#taille))
                        n + 1
                        a + *c\x[k]\y[l]
                    EndIf
                Next l
            Next k       
            *lissage\x[x]\y[y] = a/n
        Next y
    Next x
    enregistrer_bmp(*lissage, "lisse.bmp")
EndProcedure

Procedure interpolate(y1, y2, n, delta)

    ; interpolation non linéaire
    If n=0
        ProcedureReturn y1
    EndIf
    If n=1
        ProcedureReturn y2
    EndIf
    a.f = delta/n

    fac1.f = 3*Pow(1-a, 2) - 2*Pow(1-a,3)
    fac2.f = 3*Pow(a, 2) - 2*Pow(a, 3)

    ProcedureReturn y1*fac1 + y2*fac2
EndProcedure


Procedure valeur_interpolee(i, j, frequence, *r.s_Calque)
    ; valeurs des bornes
    Define borne1x, borne1y, borne2x, borne2y, q
    Define.l pas
   
    pas = #taille/frequence
    If pas = 0 : pas = 1 : EndIf

    q = i/pas
    borne1x = q*pas
    borne2x = (q+1)*pas

    If borne2x >= #taille
      borne2x = #taille-1
    EndIf     

    q = j/pas
    borne1y = q*pas
    borne2y = (q+1)*pas

    If borne2y >= #taille
      borne2y = #taille-1
    EndIf   

    Define b00,b01,b10,b11
    b00 = *r\x[borne1x]\y[borne1y]
    b01 = *r\x[borne1x]\y[borne2y]
    b10 = *r\x[borne2x]\y[borne1y]
    b11 = *r\x[borne2x]\y[borne2y]

    v1 = interpolate(b00, b01, borne2y-borne1y, j-borne1y)
    v2 = interpolate(b10, b11, borne2y-borne1y, j-borne1y)
    fin = interpolate(v1, v2, borne2x-borne1x , i-borne1x)
   
    ProcedureReturn fin
EndProcedure

Procedure aleatoire(a.f)
  ProcedureReturn Random(256)
EndProcedure

Procedure enregistrer_bmp(*c.s_Calque, filename.s)
  CreateImage(0,#taille, #taille, 32)
  If StartDrawing(ImageOutput(0))
      For i=0 To #taille-1
        For j=0 To #taille-1
          Plot(i,j,RGB(*c\x[i]\y[j],*c\x[i]\y[j],*c\x[i]\y[j]))
        Next j
      Next i   
    StopDrawing()
    SaveImage(0,filename)
  EndIf 
EndProcedure

Procedure main()

  ;valeurs d'entrée
   octaves=3
   frequence=5
   persistance.f=0.3
  lissage = 9

  ;création de calque
  Define.s_Calque *s
  *s = init_calque(persistance)
  generer_calque(frequence, octaves, persistance,lissage, *s)
  ;enregistrer_bmp(*s, "resultat.bmp")
EndProcedure


Procedure Open3D()
  ;   Init PB modules
  If InitSprite() = 0 Or InitKeyboard() = 0 Or InitMouse() = 0 
    End
  EndIf
  ; ouverture d'une fenetre grqphique compatible 3D
  DM_Graphics3D(800,600,32, 0, 1)
  ; Définit la couleur ambiante
  DM_AmbiantLight(100,  100,  100)
  ; une lumière directionnelle
  DM_CreateLight(3)
  ; creation du terrain
  DM_TerrainParams(16,16,512)
  DM_CreateTerrain("lisse.bmp", 0.18)
  ; on reprend la texture Heightmap pour 
  ; l'appliquer sur le terrain
  *brush.CBrush = DM_GetQuadBrush(0)
  *texture = DM_GetTexture(*brush, 0)
  DM_LoadTexture("lisse.bmp", *texture)
  ; creation d'une camera et son positionnement
  *camera = DM_CreateCamera()
    DM_TranslateEntity(*camera, -100,500,-100)
    DM_TurnEntity(*camera, 50,45,0)
    DM_CameraProjRatio(*camera, 800,600, 10000)

EndProcedure




main()

SetGadgetState(0,ImageID(0))
SetClipboardImage(0)
Repeat
  EventID = WaitWindowEvent()

  If EventID = #PB_Event_CloseWindow 
    Quit = 1
  EndIf

Until Quit = 1

; partie 3D
Quit=0
Open3D()
Repeat
  	ExamineKeyboard()
  	ExamineMouse() 
  	ShowCursor_(1)

    ; if Escape Key, exit	  	
    If KeyboardReleased(#PB_Key_Escape) Or WindowEvent()=#PB_Event_CloseWindow
  	  Quit=1
    EndIf
 
  	; move camera with dir key and mouse (left click)
    If KeyboardPushed(#PB_Key_Up)
  	 	DM_MoveEntity(*camera, 0,0,4)
    ElseIf KeyboardPushed(#PB_Key_Down) 
  	  DM_MoveEntity(*camera, 0,0,-4)
    EndIf
    If MouseButton(#PB_MouseButton_Left)
  		If flagXDown=0
  			omx = MouseX()
  			omy = MouseY()
  			flagXDown=11
  		Else
  			moy = MouseY()-omy
  			angley=(moy/5.0)
  			omy= MouseY()
  			mox = MouseX()-omx
  			anglex=(mox/5.0)
  			omx= MouseX()
  			DM_TurnEntity(*camera, angley,anglex,0)
  		EndIf
  	Else
  	 		flagXDown=0
    EndIf
  
  DM_BeginScene()
    	DM_RenderWorld()
 	DM_EndScene()

Until Quit = 1
Force et sagesse...
Haut
comtois
Messages : 5186
Inscription : mer. 21/janv./2004 17:48
Contact :
Contacter comtois

Message par comtois »

Cool :)

Il n'y a plus qu'à adapter ce codepour les textures.

Je ferai peut-être ça demain
http://purebasic.developpez.com/
Je ne réponds à aucune question technique en PV, utilisez le forum, il est fait pour ça, et la réponse peut profiter à tous.
Haut
_Slide_
Messages : 52
Inscription : sam. 17/mars/2007 18:04

Message par _Slide_ »

comtois a écrit :Cool :)

Il n'y a plus qu'à adapter ce codepour les textures.

Je ferai peut-être ça demain
Salut ;)

Miam :) J'en veux bien un morceau quand ca sera pret :)
Haut
Frenchy Pilou
Messages : 2194
Inscription : jeu. 27/janv./2005 19:07

Message par Frenchy Pilou »

Cà c'est de la Poudre monsieur Pimpin :)
Est beau ce qui plaît sans concept :)
Speedy Galerie
Haut
cha0s
Messages : 681
Inscription : sam. 05/mars/2005 16:09

Message par cha0s »

j'ai essayé de faire une adaptation avec des tableau pour pouvoir créer des heigthmap de diferente taille mais le resultat est pas genial :p.

Code : Tout sélectionner

#octaves=3
#frequence=5
#persistance=0.6
#lissage = 9

  Declare interpolate(y1, y2, n, delta)
  Declare valeur_interpolee(i, j, Size, *r, frequence)
  Procedure CreateHeigtmap(Size.l)
    Protected img.l, sum_pers.f = 0, temp_pers.f = #persistance
    Protected Dim FC.l(Size, Size), Dim RndC.l(Size, Size), Dim OctC.l(#octaves, Size, Size), Dim Temp.l(Size, Size)
    ;calque aleatoire
    For x = 0 To Size - 1
      For y = 0 To Size - 1
        RndC(x, y) = Random(256)
      Next y
    Next x
    
    ;creation des calques
    For oct = 0 To #octaves
      For x = 0 To Size - 1
        For y = 0 To Size - 1
          OctC(oct, x, y) = valeur_interpolee(x, y, Size, @Rndc(), temp_pers) 
        Next y
      Next x
      temp_pers * #persistance
      sum_pers + temp_pers
    Next oct 
    
    ; ajout des calques successifs 
    For x=0 To Size - 1 
        For y=0 To Size - 1 
            temp_pers = #persistance  
            For oct=0 To #octaves
                Temp(x, y) + OctC(oct, x, y) * temp_pers
                temp_pers * #persistance
            Next oct 
            ;normalisation 
            Temp(x, y) = Temp(x, y) / sum_pers 
        Next y 
    Next x 
    
    ;lissage 
    For x=0 To Size - 1
        For y=0 To Size - 1
            a=0 
            n=0 
            For k=x-#lissage To x+#lissage 
                For l=y-#lissage To y+#lissage 
                    If ((k>=0) And (k<Size) And (l>=0) And (l<Size)) 
                        n + 1 
                        a + Temp(k, l)
                    EndIf 
                Next l 
            Next k     
            FC(x, y) = a/n 
        Next y 
    Next x 
    
    ;on sauvegarde l'image
    img = CreateImage(#PB_Any, Size, Size)
    StartDrawing(ImageOutput(img))
      For x = 0 To Size - 1 
        For y = 0 To Size - 1
          val =  FC(x, y)
          Plot(x, y, (val & $ff) + ((val & $ff) << 8) + ((val & $ff) << 16))
        Next y
      Next x
    StopDrawing()
    If FileSize("test.bmp") > -1
      DeleteFile("test.bmp")
    EndIf
    SaveImage(img, "test.bmp")
  EndProcedure
  
  Procedure valeur_interpolee(i, j, Size, *r, frequence) 
    Protected pas.l, b00, b01, b10, b11, borne1x, borne1y, borne2x, borne2y, q   
    If frequence = 0
      pas = 0
    Else
      pas = Size/frequence
    EndIf
    If pas = 0 : pas = 1 : EndIf 

    q = i/pas 
    borne1x = q*pas 
    borne2x = (q+1)*pas 

    If borne2x >= Size 
      borne2x = Size-1 
    EndIf      

    q = j/pas 
    borne1y = q*pas 
    borne2y = (q+1)*pas 

    If borne2y >= Size 
      borne2y = Size-1 
    EndIf
 
    b00 = PeekC(*r + borne1x * (Size * SizeOf(long)) + borne1y)
    b01 = PeekC(*r + borne1x * (Size * SizeOf(long)) + borne2y)
    b10 = PeekC(*r + borne2x * (Size * SizeOf(long)) + borne1y)
    b11 = PeekC(*r + borne2x * (Size * SizeOf(long)) + borne2y)



    v1 = interpolate(b00, b01, borne2y-borne1y, j-borne1y) 
    v2 = interpolate(b10, b11, borne2y-borne1y, j-borne1y) 
    fin = interpolate(v1, v2, borne2x-borne1x , i-borne1x) 
    
    ProcedureReturn fin 
  EndProcedure 
  
  Procedure interpolate(y1, y2, n, delta) 
    If n=0 
      ProcedureReturn y1 
    EndIf 
    If n=1 
      ProcedureReturn y2 
    EndIf 
    a.f = delta/n 
    fac1.f = 3*Pow(1-a, 2) - 2*Pow(1-a,3) 
    fac2.f = 3*Pow(a, 2) - 2*Pow(a, 3) 
    ProcedureReturn y1*fac1 + y2*fac2 
  EndProcedure 


CreateHeigtmap(128)
Dernière modification par cha0s le dim. 22/avr./2007 1:52, modifié 1 fois.
Haut
Répondre

Revenir à « Trucs et astuces »