Antigrav

Sujets variés concernant le développement en PureBasic
Répondre
filperj
Messages : 395
Inscription : jeu. 22/janv./2004 1:13

Antigrav

Message par filperj »

Voici un... Heu... Ben, en fait, je sais pas trop ce que c'est sensé être.

Code : Tout sélectionner



#Titre="Antigrave"

#Info1="Clic gauche : place le centre de gravité"
#Info2="Clic droit : augmente/diminue la gravité"
#Info3="Barre espace : inverse l'effet du clic droit"
#Info=#Info1+#LF$+#Info2+#LF$+#Info3

MessageRequester(#Titre,#Info)


Procedure.f Deg2Rad(a.l)
  !fldpi
  !FIMUL dword[esp]
  !MOV dword[esp],180.0
  !FDIV dword[esp]
  ProcedureReturn
EndProcedure

Enumeration
  #Bob_Boule
  #Bob_Souris_B
  #Bob_Souris_R
EndEnumeration

Global RBowl,GBowl,BBowl

Procedure BowlDot(X,Y,Lum.f)
  Dist.f=Sqr(Pow(X-3.5,2)+Pow(Y-3.5,2))/13.5
  If Dist>1 : Dist=1 : EndIf
  CC=240*(1-Dist)*Lum
  Dist*Lum
  Plot(X,Y,RGB(CC+RBowl*Dist,CC+GBowl*Dist,CC+BBowl*Dist))
EndProcedure


Procedure DrawBowl(Coul.l)
  RBowl=Red(Coul)
  GBowl=Green(Coul)
  BBowl=Blue(Coul)
  For X=0 To 7
    For Y=0 To 7
      If X*X+Y*Y<=50
        If (X+1)*(X+1)+Y*Y>50 Or X*X+(Y+1)*(Y+1)>50
          Lum.f=0.5
        Else 
          Lum.f=1
        EndIf
        BowlDot(7-X,7-Y,Lum)
        BowlDot(7-X,8+Y,Lum)
        BowlDot(8+X,7-Y,Lum)
        BowlDot(8+X,8+Y,Lum)
      EndIf
    Next
  Next
EndProcedure

Procedure.l CreeSouris()
  If CreateSprite(#Bob_Souris_B,32,32) And StartDrawing(SpriteOutput(#Bob_Souris_B))
    FrontColor(0,0,120)
    LineXY(0,0,31,0)
    LineXY(0,0,0,31)
    LineXY(10,6,31,0)
    LineXY(10,6,31,31)
    LineXY(6,10,0,31)
    LineXY(6,10,31,31)
    FillArea(1,1,RGB(0,0,120),RGB(0,0,180))
    StopDrawing()
    If CreateSprite(#Bob_Souris_R,32,32) And StartDrawing(SpriteOutput(#Bob_Souris_R))
      FrontColor(120,0,0)
      LineXY(0,0,31,0)
      LineXY(0,0,0,31)
      LineXY(10,6,31,0)
      LineXY(10,6,31,31)
      LineXY(6,10,0,31)
      LineXY(6,10,31,31)
      FillArea(1,1,RGB(120,0,0),RGB(180,0,0))
      StopDrawing()
      ProcedureReturn 1
    EndIf
  EndIf
EndProcedure


#ScrW=640
#ScrH=480
#ScrDepth=16
#AutoStretch=0
#WinStyle=#PB_Window_SystemMenu|#PB_Window_ScreenCentered|#PB_Window_MinimizeGadget|((#PB_Window_MaximizeGadget|#PB_Window_SizeGadget)*#AutoStretch)
Global PleinEcran.l


Procedure.l Initiale()
  Select MessageRequester(#Titre,"Plein écran ?",#PB_MessageRequester_YesNo)
    Case 6;oui
      PleinEcran=1
      If InitSprite() And InitKeyboard() And InitMouse() And OpenScreen(#ScrW,#ScrH,#ScrDepth,#Titre)
        OK=1
      EndIf
    Case 7;non
      If InitSprite() And OpenWindow(0,0,0,#ScrW,#ScrH,#WinStyle,#Titre) And OpenWindowedScreen(WindowID(0),0,0,#ScrW,#ScrH,#AutoStretch,0,0)
        OK=1
      EndIf
  EndSelect
  If OK And CreateSprite(#Bob_Boule,16,16) And StartDrawing(SpriteOutput(#Bob_Boule))
    Box(0,0,16,16,$FF00FF)
    DrawBowl(0)
    StopDrawing()
    TransparentSpriteColor(#Bob_Boule,255,0,255)
    If PleinEcran
      If CreeSouris()=0 : ProcedureReturn 0 : EndIf
      MouseLocate(#ScrW/2,#ScrH/2)
    EndIf
    ProcedureReturn 1
  EndIf
EndProcedure

Structure Souris
  X.l : Y.l
  BtG.l : BtD.l
  PtrBob.l
EndStructure

Global Souris.Souris , Quitt.l , Barresp.l


Procedure Flippon()
  If PleinEcran
    ExamineMouse()
    Souris\X=MouseX()
    Souris\Y=MouseY()
    Souris\BtG=MouseButton(1)
    Souris\BtD=MouseButton(2)
    ExamineKeyboard()
    Quitt=KeyboardPushed(#PB_Key_Escape)
    Barresp=KeyboardReleased(#PB_Key_Space)
    DisplayTransparentSprite(Souris\PtrBob,Souris\X,Souris\Y)
    FlipBuffers()
    While IsScreenActive()=0
      Delay(20)
      FlipBuffers()
    Wend
  Else
    While Quitt=0 And IsIconic_(WindowID(0))
      If WaitWindowEvent()=#PB_Event_CloseWindow : Quitt=1 : EndIf
    Wend
    Barresp=0
    Repeat
      Select WindowEvent()
        Case 0 : Break
        Case #wm_lbuttondown : Souris\BtG=1
        Case #wm_lbuttonup   : Souris\BtG=0
        Case #wm_rbuttondown : Souris\BtD=1
        Case #wm_rbuttonup   : Souris\BtD=0
        Case #PB_Event_CloseWindow : Quitt=1
        Case #wm_char
          Select EventwParam()
            Case 27 : Quitt=1
            Case 32 : Barresp=1
          EndSelect
      EndSelect
    ForEver
    m=WindowMouseX()
    If m<=0
      Souris\X=0
    ElseIf m>=#ScrW
      Souris\X=#ScrW-1
    Else
      Souris\X=m
    EndIf
    m=WindowMouseY()
    If m<=0
      Souris\Y=0
    ElseIf m>=#ScrH
      Souris\Y=#ScrH-1
    Else
      Souris\Y=m
    EndIf
    FlipBuffers()
  EndIf
  ClearScreen(0,0,0)
EndProcedure

Procedure ActuPtr(Mode)
  Static OldMode.l
  If Mode<>OldMode
    OldMode=Mode
    If PleinEcran
      If Mode>0
        Souris\PtrBob=#Bob_Souris_R
      Else
        Souris\PtrBob=#Bob_Souris_B
      EndIf
    Else
      If Mode>0
        SetWindowTitle(0,"Augmenter la gravité")
      Else
        SetWindowTitle(0,"Diminuer la gravité")
      EndIf
    EndIf
  EndIf
EndProcedure

Structure Bouboule
  X.f : Y.f : VX.f : VY.f
EndStructure
#nbBoules=300
Dim Boules.Bouboule(#nbBoules-1)

For b=0 To #nbBoules-1
  Ang.f=Deg2Rad(Random(359))
  Vit.f=Random(3000)/1000
  Boules(b)\VX=Vit*Sin(Ang)
  Boules(b)\VY=Vit*Cos(Ang)
Next


Global CenterX.f , CenterY.f , Pulse.f

Procedure TraiteBoules()
  For b=0 To #nbBoules-1
    VX.f=Boules(b)\VX
    VY.f=Boules(b)\VY
    X.f=Boules(b)\X+VX
    If X<0
      X=0
      VX=-VX
    ElseIf X>#ScrW-16
      X=#ScrW-16
      VX=-VX
    EndIf
    Y.f=Boules(b)\Y+VY
    If Y<0
      Y=0
      VY=-VY
    ElseIf Y>#ScrH-16
      Y=#ScrH-16
      VY=-VY
    EndIf
    For b2=b-1 To 0 Step -1
      X2.f=X-Boules(b2)\X
      Y2.f=Y-Boules(b2)\Y
      sX2=X2/Abs(X2) : sY2=Y2/Abs(Y2)
      X2*X2 : Y2*Y2
      SXY.f=X2+Y2
      Dist.f=Sqr(SXY)
      If Dist>0.00001
        X2/SXY : Y2/SXY
        Accel.f=1/Dist
        VX+(Accel*Sqr(X2)*sX2)
        VY+(Accel*Sqr(Y2)*sY2)
      EndIf
    Next
    For b2=b+1 To #nbBoules-1
      X2.f=X-Boules(b2)\X
      Y2.f=Y-Boules(b2)\Y
      sX2=X2/Abs(X2) : sY2=Y2/Abs(Y2)
      X2*X2 : Y2*Y2
      SXY.f=X2+Y2
      Dist.f=Sqr(SXY)
      If Dist>0.00001
        X2/SXY : Y2/SXY
        Accel.f=1/Dist
        VX+(Accel*Sqr(X2)*sX2)
        VY+(Accel*Sqr(Y2)*sY2)
      EndIf
    Next
    Boules(b)\X=X+(CenterX-X)*Pulse
    Boules(b)\Y=Y+(CenterY-Y)*Pulse
    Boules(b)\VX=VX*0.85
    Boules(b)\VY=VY*0.85
    DisplayTransparentSprite(#Bob_Boule,X,Y)
  Next
EndProcedure

PulseM=1
If Initiale()
  Repeat
    If Souris\BtD
      PulseI=(PulseI+PulseM)&1023
      If PulseI=0 : PulseM=-PulseM : EndIf
      Pulse=PulseI*0.001
    EndIf
    If Souris\BtG
      CenterX=Souris\X
      CenterY=Souris\Y
    EndIf
    If Barresp
      PulseM=-PulseM
    EndIf
    ActuPtr(PulseM)
    TraiteBoules()
    Flippon()
  Until Quitt
EndIf
Le chaos l'emporte toujours sur l'ordre
parcequ'il est mieux organisé.
(Ly Tin Wheedle)
Haut
comtois
Messages : 5186
Inscription : mer. 21/janv./2004 17:48
Contact :
Contacter comtois

Message par comtois »

j'aime bien , jolie démo :)
Haut
Le Soldat Inconnu
Messages : 4312
Inscription : mer. 28/janv./2004 20:58
Localisation : Clermont ferrand OU Olsztyn
Contact :
Contacter Le Soldat Inconnu

Message par Le Soldat Inconnu »

:D joli
Je ne suis pas à moitié Polonais mais ma moitié est polonaise ... Vous avez suivi ?

[Intel quad core Q9400 2.66mhz, ATI 4870, 4Go Ram, XP (x86) / 7 (x64)]
Haut
Avatar de l’utilisateur
Thyphoon
Messages : 2706
Inscription : mer. 25/août/2004 6:31
Localisation : Eragny
Contact :
Contacter Thyphoon

Message par Thyphoon »

Version PB4

Code : Tout sélectionner

#Titre="Antigrave"

#Info1="Clic gauche : place le centre de gravité"
#Info2="Clic droit : augmente/diminue la gravité"
#Info3="Barre espace : inverse l'effet du clic droit"
#Info=#Info1+#LF$+#Info2+#LF$+#Info3

MessageRequester(#Titre,#Info)


Procedure.f Deg2Rad(a.l)
  
  ProcedureReturn a*180/#PI
EndProcedure

Enumeration
  #Bob_Boule
  #Bob_Souris_B
  #Bob_Souris_R
EndEnumeration

Global RBowl,GBowl,BBowl

Procedure BowlDot(X,Y,Lum.f)
  Dist.f=Sqr(Pow(X-3.5,2)+Pow(Y-3.5,2))/13.5
  If Dist>1 : Dist=1 : EndIf
  CC=240*(1-Dist)*Lum
  Dist*Lum
  Plot(X,Y,RGB(CC+RBowl*Dist,CC+GBowl*Dist,CC+BBowl*Dist))
EndProcedure


Procedure DrawBowl(Coul.l)
  RBowl=Red(Coul)
  GBowl=Green(Coul)
  BBowl=Blue(Coul)
  For X=0 To 7
    For Y=0 To 7
      If X*X+Y*Y<=50
        If (X+1)*(X+1)+Y*Y>50 Or X*X+(Y+1)*(Y+1)>50
          Lum.f=0.5
        Else
          Lum.f=1
        EndIf
        BowlDot(7-X,7-Y,Lum)
        BowlDot(7-X,8+Y,Lum)
        BowlDot(8+X,7-Y,Lum)
        BowlDot(8+X,8+Y,Lum)
      EndIf
    Next
  Next
EndProcedure

Procedure.l CreeSouris()
  If CreateSprite(#Bob_Souris_B,32,32) And StartDrawing(SpriteOutput(#Bob_Souris_B))
    FrontColor(RGB(0,0,120))
    LineXY(0,0,31,0)
    LineXY(0,0,0,31)
    LineXY(10,6,31,0)
    LineXY(10,6,31,31)
    LineXY(6,10,0,31)
    LineXY(6,10,31,31)
    FillArea(1,1,RGB(0,0,120),RGB(0,0,180))
    StopDrawing()
    If CreateSprite(#Bob_Souris_R,32,32) And StartDrawing(SpriteOutput(#Bob_Souris_R))
      FrontColor(RGB(120,0,0))
      LineXY(0,0,31,0)
      LineXY(0,0,0,31)
      LineXY(10,6,31,0)
      LineXY(10,6,31,31)
      LineXY(6,10,0,31)
      LineXY(6,10,31,31)
      FillArea(1,1,RGB(120,0,0),RGB(180,0,0))
      StopDrawing()
      ProcedureReturn 1
    EndIf
  EndIf
EndProcedure


#ScrW=640
#ScrH=480
#ScrDepth=16
#AutoStretch=0
#WinStyle=#PB_Window_SystemMenu|#PB_Window_ScreenCentered|#PB_Window_MinimizeGadget|((#PB_Window_MaximizeGadget|#PB_Window_SizeGadget)*#AutoStretch)
Global PleinEcran.l


Procedure.l Initiale()
  Select MessageRequester(#Titre,"Plein écran ?",#PB_MessageRequester_YesNo)
    Case 6;oui
      PleinEcran=1
      If InitSprite() And InitKeyboard() And InitMouse() And OpenScreen(#ScrW,#ScrH,#ScrDepth,#Titre)
        OK=1
      EndIf
    Case 7;non
      If InitSprite() And OpenWindow(0,0,0,#ScrW,#ScrH,#Titre,#WinStyle) And OpenWindowedScreen(WindowID(0),0,0,#ScrW,#ScrH,#AutoStretch,0,0)
        OK=1
      EndIf
  EndSelect
  If OK And CreateSprite(#Bob_Boule,16,16) And StartDrawing(SpriteOutput(#Bob_Boule))
    Box(0,0,16,16,$FF00FF)
    DrawBowl(0)
    StopDrawing()
    TransparentSpriteColor(#Bob_Boule,RGB(255,0,255))
    If PleinEcran
      If CreeSouris()=0 : ProcedureReturn 0 : EndIf
      MouseLocate(#ScrW/2,#ScrH/2)
    EndIf
    ProcedureReturn 1
  EndIf
EndProcedure

Structure Souris
  X.l : Y.l
  BtG.l : BtD.l
  PtrBob.l
EndStructure

Global Souris.Souris , Quitt.l , Barresp.l


Procedure Flippon()
  If PleinEcran
    ExamineMouse()
    Souris\X=MouseX()
    Souris\Y=MouseY()
    Souris\BtG=MouseButton(1)
    Souris\BtD=MouseButton(2)
    ExamineKeyboard()
    Quitt=KeyboardPushed(#PB_Key_Escape)
    Barresp=KeyboardReleased(#PB_Key_Space)
    DisplayTransparentSprite(Souris\PtrBob,Souris\X,Souris\Y)
    FlipBuffers()
    While IsScreenActive()=0
      Delay(20)
      FlipBuffers()
    Wend
  Else
    While Quitt=0 And IsIconic_(WindowID(0))
      If WaitWindowEvent()=#PB_Event_CloseWindow : Quitt=1 : EndIf
    Wend
    Barresp=0
    Repeat
      Select WindowEvent()
        Case 0 : Break
        Case #WM_LBUTTONDOWN : Souris\BtG=1
        Case #WM_LBUTTONUP   : Souris\BtG=0
        Case #WM_RBUTTONDOWN : Souris\BtD=1
        Case #WM_RBUTTONUP   : Souris\BtD=0
        Case #PB_Event_CloseWindow : Quitt=1
        Case #WM_CHAR
          Select EventwParam()
            Case 27 : Quitt=1
            Case 32 : Barresp=1
          EndSelect
      EndSelect
    ForEver
    m=WindowMouseX(0)
    If m<=0
      Souris\X=0
    ElseIf m>=#ScrW
      Souris\X=#ScrW-1
    Else
      Souris\X=m
    EndIf
    m=WindowMouseY(0)
    If m<=0
      Souris\Y=0
    ElseIf m>=#ScrH
      Souris\Y=#ScrH-1
    Else
      Souris\Y=m
    EndIf
    FlipBuffers()
  EndIf
  ClearScreen(0)
EndProcedure

Procedure ActuPtr(Mode)
  Static OldMode.l
  If Mode<>OldMode
    OldMode=Mode
    If PleinEcran
      If Mode>0
        Souris\PtrBob=#Bob_Souris_R
      Else
        Souris\PtrBob=#Bob_Souris_B
      EndIf
    Else
      If Mode>0
        SetWindowTitle(0,"Augmenter la gravité")
      Else
        SetWindowTitle(0,"Diminuer la gravité")
      EndIf
    EndIf
  EndIf
EndProcedure

Structure Bouboule
  X.f : Y.f : VX.f : VY.f
EndStructure
#nbBoules=300
Global Dim Boules.Bouboule(#nbBoules-1)

For b=0 To #nbBoules-1
  Ang.f=Deg2Rad(Random(359))
  Vit.f=Random(3000)/1000
  Boules(b)\VX=Vit*Sin(Ang)
  Boules(b)\VY=Vit*Cos(Ang)
Next


Global CenterX.f , CenterY.f , Pulse.f

Procedure TraiteBoules()
  For b=0 To #nbBoules-1
    VX.f=Boules(b)\VX
    VY.f=Boules(b)\VY
    X.f=Boules(b)\X+VX
    If X<0
      X=0
      VX=-VX
    ElseIf X>#ScrW-16
      X=#ScrW-16
      VX=-VX
    EndIf
    Y.f=Boules(b)\Y+VY
    If Y<0
      Y=0
      VY=-VY
    ElseIf Y>#ScrH-16
      Y=#ScrH-16
      VY=-VY
    EndIf
    For b2=b-1 To 0 Step -1
      X2.f=X-Boules(b2)\X
      Y2.f=Y-Boules(b2)\Y
      sX2=X2/Abs(X2) : sY2=Y2/Abs(Y2)
      X2*X2 : Y2*Y2
      SXY.f=X2+Y2
      Dist.f=Sqr(SXY)
      If Dist>0.00001
        X2/SXY : Y2/SXY
        Accel.f=1/Dist
        VX+(Accel*Sqr(X2)*sX2)
        VY+(Accel*Sqr(Y2)*sY2)
      EndIf
    Next
    For b2=b+1 To #nbBoules-1
      X2.f=X-Boules(b2)\X
      Y2.f=Y-Boules(b2)\Y
      sX2=X2/Abs(X2) : sY2=Y2/Abs(Y2)
      X2*X2 : Y2*Y2
      SXY.f=X2+Y2
      Dist.f=Sqr(SXY)
      If Dist>0.00001
        X2/SXY : Y2/SXY
        Accel.f=1/Dist
        VX+(Accel*Sqr(X2)*sX2)
        VY+(Accel*Sqr(Y2)*sY2)
      EndIf
    Next
    Boules(b)\X=X+(CenterX-X)*Pulse
    Boules(b)\Y=Y+(CenterY-Y)*Pulse
    Boules(b)\VX=VX*0.85
    Boules(b)\VY=VY*0.85
    DisplayTransparentSprite(#Bob_Boule,X,Y)
  Next
EndProcedure

PulseM=1
If Initiale()
  Repeat
    If Souris\BtD
      PulseI=(PulseI+PulseM)&1023
      If PulseI=0 : PulseM=-PulseM : EndIf
      Pulse=PulseI*0.001
    EndIf
    If Souris\BtG
      CenterX=Souris\X
      CenterY=Souris\Y
    EndIf
    If Barresp
      PulseM=-PulseM
    EndIf
    ActuPtr(PulseM)
    TraiteBoules()
    Flippon()
  Until Quitt
EndIf
Haut
Stefou
Messages : 234
Inscription : jeu. 18/janv./2007 14:08

Message par Stefou »

Superbe :D 8O
Haut
Frenchy Pilou
Messages : 2194
Inscription : jeu. 27/janv./2005 19:07

Message par Frenchy Pilou »

En couleurs et plus grosses cela ferait une jolie cascade de "smarties" :lol:
Haut
Avatar de l’utilisateur
Ar-S
Messages : 9540
Inscription : dim. 09/oct./2005 16:51
Contact :
Contacter Ar-S

Message par Ar-S »

Trés jolie !!
Haut
Répondre

Revenir à « Discussion générale »