PureBasic

Code : Tout sélectionner

EnableExplicit

Global.l i, j, k, l
Define.f val=48       ; isovaleur, c'est le seuil auquel on dessine une ligne
Define.l res=32       ; resolution: Le nombre de fois où on divise l'écran... 

DataSection
  
  ; voici les 16 cas du marching square
  ; la première valeur correspond au nombre de lignes à tracer x2
  ; les paires de valeurs suivantes correspondent aux arrêtes à joindre par les lignes
  datas:
  Data.l 0            ; 0000 format DCBA (voir plus bas)
  Data.l 2, 0,3       ; 0001
  Data.l 2, 0,1       ; 0010
  Data.l 2, 1,3       ; 0011
  Data.l 2, 1,2       ; 0100
  Data.l 4, 0,3, 1,2  ; 0101 par exemple ici nous traçons 2 lignes, qui joignent les arrêtes 0-3 et 1-2
  Data.l 2, 0,2       ; 0110
  Data.l 2, 2,3       ; 0111
  Data.l 2, 2,3       ; 1000
  Data.l 2, 0,2       ; 1001
  Data.l 4, 2,3, 0,1  ; 1010
  Data.l 2, 1,2       ; 1011
  Data.l 2, 1,3       ; 1100
  Data.l 2, 0,1       ; 1101
  Data.l 2, 0,3       ; 1110
  Data.l 0            ; 1111
  
  ; ces 4 positions correspondent au centre des 4 arrêtes AB (0) BC (1) CD (2) DA (3)
  Data.f 0.5, 1       ;     D--2--C       Les 4 coins sont notés A B C D
  Data.f 1, 0.5       ; 3-> |     |       Les 4 arrêtes numérotées de 0 à 3
  Data.f 0.5, 0       ;     |     | <-1
  Data.f 0, 0.5       ;     A--0--B
  
EndDataSection

Procedure exit(text$)
  If text$ : Debug (text$) : EndIf
  End  
EndProcedure



If Not(InitMouse() And InitKeyboard() And InitSprite())
  exit("Can't init something")
EndIf

Define.l win=OpenWindow(#PB_Any, 0, 0, 1024, 1024, "", #PB_Window_ScreenCentered)
If Not(win) : exit("Can't open window") : EndIf
Define.l width=WindowWidth(win), height=WindowHeight(win)
Define.f stepx=width/res, stepy=height/res ; step x et step y = écran / résolution
If Not(OpenWindowedScreen(WindowID(win),0, 0, width, height))
exit("Can't open screen") : EndIf

Restore datas

Dim cnt(15)
Dim lines(15, 3)

For j=0 To 15
  Read.l cnt(j)
  For i=0 To cnt(j)-1
    Read.l lines(j, i)
  Next
Next

Dim posx.f(3) : Dim posy.f(3)
For i=0 To 3
  Read.f posx(i)
  Read.f posy(i)
Next

Dim lvl.f(res, res)

Global event
Define run=#True

Define.f t=0

While run
  
  t+0.01
  
  ; on nettoie la grille
  
  For j=0 To res
    For i=0 To res      
      lvl(i, j)=0
    Next
  Next
  
  ; on place quelques metaball sur la grille
  
  For k=0 To 5
    Define.f ballx, bally, balld
    ballx=(0.5+Cos(t+k*2.5)*0.5)*res  ; position x de la metaball
    bally=(0.5+Sin(t*1.5+k)*0.5)*res  ; position y de la metaball
    balld=res*res                     ; diametre de la metaball
    
    For j=0 To res
      For i=0 To res
        lvl(i, j)+balld/(Pow(ballx-i,2)+Pow(bally-j, 2))
      Next
    Next
  Next
  
  ClearScreen(0)
  StartDrawing(ScreenOutput())
  
  ; on dessine la grille dépendante de la résolution
  
  For i=0 To res
    LineXY(i*stepx, 0 ,i*stepx, height, $A00000)
    LineXY(0, i*stepy, width, i*stepy, $A00000)   
  Next
  
  ; on trace les metaballs
  
  For j=0 To res-1
    For i=0 To res-1
      
      ; détermination du cas dans lequel on se trouve
      
      Define cas.l = 0
      If lvl(i+0, j+1) > val : cas+1 : EndIf ; coin A
      If lvl(i+1, j+1) > val : cas+2 : EndIf ; coin B
      If lvl(i+1, j+0) > val : cas+4 : EndIf ; coin C
      If lvl(i+0, j+0) > val : cas+8 : EndIf ; coin D
      
      ; interpolation des arrêtes
      ; si vous êtes curieux vous pouvez commenter toute cette boucle "for k" jusqu'au prochain commentaire
      ; il est alors conseillé de monter fortement en résolution
      
      For k=0 To cnt(cas)-1
        Define.l side=lines(cas, k)
        Define.f a, b
        
        If side=0
          a=lvl(i+0, j+1)
          b=lvl(i+1, j+1)-a
          posx(0)=(val-a)/b
        EndIf
        
        If side=2
          a=lvl(i+0, j+0)
          b=lvl(i+1, j+0)-a
          posx(2)=(val-a)/b
        EndIf
        
        If side=1
          a=lvl(i+1, j+0)
          b=lvl(i+1, j+1)-a
          posy(1)=(val-a)/b
        EndIf
        
        If side=3
          a=lvl(i+0, j+0)
          b=lvl(i+0, j+1)-a
          posy(3)=(val-a)/b
        EndIf
      Next
      
      ; traçage des lignes
      
      For k=0 To cnt(cas)-1 Step 2
        Define.f xa, ya, xb, yb
        xa=posx(lines(cas, k))
        ya=posy(lines(cas, k))
        xb=posx(lines(cas, k+1))
        yb=posy(lines(cas, k+1))
        LineXY((i+xa)*stepx, (j+ya)*stepy, (i+xb)*stepx, (j+yb)*stepy, $ffffff)
      Next
      
    Next
  Next
  
  StopDrawing()
  
  FlipBuffers()  
  
  If ExamineKeyboard()
    If KeyboardReleased(#PB_Key_Escape)
      run=#False
    EndIf  
  EndIf
  
  Repeat
    Event = WindowEvent()
    Select Event
      Case #PB_Event_CloseWindow
        run=#False
    EndSelect
  Until Event=0
Wend

exit("")