Meridians and Parallels

Share your advanced PureBasic knowledge/code with the community.
User avatar
einander
Enthusiast
Enthusiast
Posts: 744
Joined: Thu Jun 26, 2003 2:09 am
Location: Spain (Galicia)

Meridians and Parallels

Post by einander »

Code: Select all

 ;Meridians and Parallels
    ;by einander
    ;PB 4.60

    EnableExplicit
    InitEngine3D()
    InitKeyboard()
    InitSprite()
    ;
    Structure Vector:X.D:Y.D:Z.D:EndStructure
    #RADTODEG=180.0/#PI
    Global _CamSpeed.D=1,_VCenter.Vector,_Mainmesh,_Quit
    Define Wi,He,I,Siz.Vector
    ;
    Macro GadRGB(Gad,RGB1=$FFFFFF,RGB2=0)
      SetGadgetColor(Gad,1,RGB1)     
      SetGadgetColor(Gad,2,RGB2)   
    EndMacro
    ;
    Procedure KeyMap(Node,Cam)  ; Control  moving and rotating with Keyboard
      ; -------
      Macro KBP(Key1,Key2)
        (KeyboardPushed(#PB_Key_#Key1) Or KeyboardPushed(#Pb_Key_#Key2))
      EndMacro
      ; -------
      If KBP(Add,F1)         
        MoveCamera(Cam, 0,0, -_CamSpeed*2)               ; Move to front
      ElseIf KBP(Subtract,F2)         
        MoveCamera(Cam, 0, 0,_CamSpeed*2)                ; Move to rear
        ; ------------------------------
        ; Arrow keys; move camera to 4  Directions
      ElseIf KeyboardPushed(#PB_Key_Left)             
        MoveNode(Node, _CamSpeed, 0, 0)                  ; Move to screen Left
      ElseIf KeyboardPushed(#PB_Key_Right)             
        MoveNode(Node, -_CamSpeed, 0, 0)                 ; Move to screen Right
      ElseIf KeyboardPushed(#PB_Key_Up)             
        MoveNode(Node, 0,-_CamSpeed, 0)                  ; Move to screen Top
      ElseIf KeyboardPushed(#PB_Key_Down)             
        MoveNode(Node, 0,_CamSpeed, 0)                   ; Move to screen Bottom
        ; -------------------
        ;PageUp - Insert
      ElseIf KBP(F3,PageUp)
        RotateNode(Node,0,0,_CamSpeed*2,#PB_Relative)    ; Turn Left
      ElseIf KBP(F4,Insert)
        RotateNode(Node,0,0,-_CamSpeed*2,#PB_Relative)   ; Turn Right
        ; ---------------------
        ;Home / End     
      ElseIf KBP(F5,Home)
        RotateNode(Node,_CamSpeed,0,0,#PB_Relative)      ; Turn back
      ElseIf KBP(F6,End)
        RotateNode(Node,-_CamSpeed,0,0,#PB_Relative)     ; Turn front
        ; -------------
        ;Delete / PageDown
      ElseIf KBP(F7,Delete)
        RotateNode(Node,0, _CamSpeed,0,#PB_Relative)     ; Rotation Left
      ElseIf KBP(F8,PageDown)
        RotateNode(Node,0,- _CamSpeed,0,#PB_Relative)    ; Rotation Right
      EndIf
    EndProcedure
    ;
    Procedure MkSphere(Sph,Merid,Paral,*Siz.Vector)
      RandomSeed(2)
      Paral*2
      Protected.D K, J, XStp=360/Merid, YStp=180/Paral
      Protected N,A,I, RGB,Arrsiz 
      Protected Dim Vx.Vector(0)
      Repeat
        K.D=0
        J+YStp 
        Repeat
          ReDim Vx(N)
          VX(N)\X =*Siz\X *  Sin((K) / #Radtodeg) * Sin((J) / #Radtodeg)
          VX(N)\Y =*Siz\Y *  Cos((K) / #Radtodeg) * Sin((J) / #Radtodeg)
          VX(N)\Z =*Siz\Z *  Cos((J) / #Radtodeg)
          N+1
          K+XStp 
        Until K>=359
        J+YStp 
      Until J>=179
      Arrsiz=ArraySize(Vx())
      For I = 0 To Arrsiz
        If I%Merid=0
          RGB=Random($FFFFFF)
        EndIf
        CreateEntity(I,MeshID(Sph),#PB_Material_None,Vx(I)\X,Vx(I)\Y,Vx(I)\Z) ;   parallels
        If I%Merid:    A=I-1
        Else      :    A=I+Merid-1
        EndIf     
        CreateLine3D(I,Vx(A)\X,Vx(A)\Y,Vx(A)\Z,RGB,Vx(I)\X,Vx(I)\Y,Vx(I)\Z,RGB)
        If I<Arrsiz-Merid+1   
          A=I+Merid
          CreateLine3D(I+Arrsiz+1,Vx(A)\X,Vx(A)\Y,Vx(A)\Z,RGB,Vx(I)\X,Vx(I)\Y,Vx(I)\Z,RGB) ; meridians
        EndIf
      Next
      Dim Vx(0)
      ProcedureReturn Arrsiz
    EndProcedure
    ;
    ; <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    Define T$= "Keys: Left, Right, Up, Down, PageUp, PageDown, Insert, Delete, Home, End, +, -, F1 to F8, <Spc> to auto rotation."
    OpenWindow(0, 100, 100,700,500 ,T$,  #PB_Window_SystemMenu|#PB_Window_Maximize|#PB_Window_Invisible)
    SetWindowColor(0,0)
    Wi=WindowWidth(0):He=WindowHeight(0)
    Define X1=Wi-200
    Siz\X=100:Siz\Y=100:Siz\Z=100
    Define Merid=6 ; meridians
    Define Paral=4  ;parallels
    Define Radius.D=0
    Define TBX=TrackBarGadget(-1,X1,10,180,26,0,500)
    Define TBY=TrackBarGadget(-1,X1,50,180,26,0,500)
    Define TBZ=TrackBarGadget(-1,X1,90,180,26,0,500)
    Define SpMerid=SpinGadget(-1,X1,170,80,30,1,100,#PB_Spin_Numeric)
    Define SpParal=SpinGadget(-1,X1,210,80,30,1,100,#PB_Spin_Numeric)
    Define TBSphere=TrackBarGadget(-1,X1,130,180,26,0,300)
    Define TG=TextGadget(-1,0,0, Wi-210,24,"")
    Define Draw=1,AutoRotate=1

    TextGadget(0,X1+90,170,80,26,"Meridians")
    TextGadget(1,X1+90,210,80,26,"Parallels")
    GadRGB(0,$FFFFFF,0)
    GadRGB(1,$FFFFFF,0)
    SetGadgetState(SpMerid,Merid)
    SetGadgetState(SpParal,Paral)
    SetGadgetState(TBX,Siz\X)   
    SetGadgetState(TBY,Siz\Y)   
    SetGadgetState(TBZ,Siz\Z)   
    SetGadgetState(TbSphere,Radius*10)
    GadRGB(Tg,$FFFFFF,0)
    HideWindow(0,0)
    ; ------------------------
    AntialiasingMode(#PB_AntialiasingMode_x4)
    OpenWindowedScreen(WindowID(0),0,24,X1-10,He,0,0,0,#PB_Screen_SmartSynchronization)
    KeyboardMode(#PB_Keyboard_International)
    Define Sph=CreateSphere(-1,Radius)
    Define Arrsiz=MkSphere(Sph,Merid,Paral,Siz)
    ;
    CreateNode(0,0,0,0)
    CreateCamera(0, 0, 0, 100, 100)
    CameraLocate(0, 0, 0, 400)
    AttachNodeObject(0,CameraID(0),#PB_Node_Camera)
    ;
    CreateLight(0, $Ddeeff ,-200, 0  ,-100)
    CreateLight(1, $Bbccdd , 200, 0  , 100)
    CreateLight(2, $FFff   , 0  , 200, 0)
    AmbientColor($112233)
    Repeat
        Select WindowEvent()
        Case #PB_Event_CloseWindow :_Quit=#True  
        Case #PB_Event_Gadget 
          Select EventGadget()
            Case TBX,TBY,TBZ
              Siz\X=GetGadgetState(TBX)   
              Siz\Y=GetGadgetState(TBY)   
              Siz\Z=GetGadgetState(TBZ)   
              Arrsiz=MkSphere(Sph,Merid,Paral,Siz)
              SetActiveGadget(Tg)
              Draw=1
            Case SpMerid,SpParal
              For I=0 To ArrSiz*2
                If IsEntity(I):FreeEntity(I):EndIf
                If IsMesh(I)  :FreeMesh(I)  :EndIf
              Next
              Merid=GetGadgetState(SpMerid)
              Paral=GetGadgetState(SpParal)
              Arrsiz=MkSphere(Sph,Merid,Paral,Siz)
              SetActiveGadget(Tg)
              Draw=1
            Case TbSphere
              Radius=GetGadgetState(TbSphere)/10
              FreeMesh(Sph)
              Sph=CreateSphere(-1,Radius)
              Arrsiz=MkSphere(Sph,Merid,Paral,Siz)
              SetActiveGadget(Tg)
              Draw=1
          EndSelect
        Default
          If ExamineKeyboard() Or Draw
            If KeyboardPushed(#PB_Key_Escape) :_Quit=#True :EndIf
            If KeyboardReleased(#PB_Key_Space):AutoRotate!1:EndIf
            If Draw=0:Keymap(0,0) :EndIf
            Draw=1 
          EndIf
      EndSelect
      If AutoRotate Or Draw
        If AutoRotate
          RotateNode(0,0,0,0.2,#PB_Relative)       
          RotateNode(0,0,0.5,0,#PB_Relative)       
          Draw=1 
        EndIf 
        RenderWorld()
        FlipBuffers()
        Draw=0
      EndIf
    Until  _Quit
    End 
Cheers!
Last edited by einander on Thu Dec 22, 2011 10:55 am, edited 1 time in total.
User avatar
BasicallyPure
Enthusiast
Enthusiast
Posts: 539
Joined: Thu Mar 24, 2011 12:40 am
Location: Iowa, USA

Re: Meridians and Parallels

Post by BasicallyPure »

Very nice work!

My suggestions to Linux users:

Set Compiler/CompilerOptions/LibrarySubsystem to 'opengl'.

Add somewhere at the beginning

Code: Select all

#White = $FFFFFF
after

Code: Select all

OpenWindowedScreen(WindowID(0),0,24,X1-10,He,0,0,0,#PB_Screen_SmartSynchronization)
add

Code: Select all

KeyboardMode(#PB_Keyboard_International)
For any user, change

Code: Select all

Case 16:_Quit=#True
To

Code: Select all

Case 16, #PB_Event_CloseWindow :_Quit=#True
B.P.
BasicallyPure
Until you know everything you know nothing, all you have is what you believe.
User avatar
einander
Enthusiast
Enthusiast
Posts: 744
Joined: Thu Jun 26, 2003 2:09 am
Location: Spain (Galicia)

Re: Meridians and Parallels

Post by einander »

Thanks B.P.
Changed the first post with your suggestions.
Cheers!
LuaDev
User
User
Posts: 33
Joined: Tue Feb 16, 2010 2:41 pm

Re: Meridians and Parallels

Post by LuaDev »

i get:

"invalid memory access (read error at address 0)"

on line 134

Code: Select all

Define Sph=CreateSphere(-1,Radius)
User avatar
BasicallyPure
Enthusiast
Enthusiast
Posts: 539
Joined: Thu Mar 24, 2011 12:40 am
Location: Iowa, USA

Re: Meridians and Parallels

Post by BasicallyPure »

LuaDev wrote:i get:

"invalid memory access (read error at address 0)"
Try this:
Set Compiler/CompilerOptions/LibrarySubsystem to 'opengl'.

B.P.
BasicallyPure
Until you know everything you know nothing, all you have is what you believe.
LuaDev
User
User
Posts: 33
Joined: Tue Feb 16, 2010 2:41 pm

Re: Meridians and Parallels

Post by LuaDev »

Yup, that worked, nice example, way over my head tho!
yrreti
Enthusiast
Enthusiast
Posts: 546
Joined: Tue Oct 31, 2006 4:34 am

Re: Meridians and Parallels

Post by yrreti »

einander, really really cool job!
Thanks for sharing.
User avatar
Kwai chang caine
Always Here
Always Here
Posts: 5494
Joined: Sun Nov 05, 2006 11:42 pm
Location: Lyon - France

Re: Meridians and Parallels

Post by Kwai chang caine »

Nice...thanks for sharing 8)
ImageThe happiness is a road...
Not a destination
rsts
Addict
Addict
Posts: 2736
Joined: Wed Aug 24, 2005 8:39 am
Location: Southwest OH - USA

Re: Meridians and Parallels

Post by rsts »

Wow :shock:

You do some of the coolest 8) things.

Thanks for sharing them.
User avatar
einander
Enthusiast
Enthusiast
Posts: 744
Joined: Thu Jun 26, 2003 2:09 am
Location: Spain (Galicia)

Re: Meridians and Parallels

Post by einander »

Thank you all for the support! :D
User avatar
einander
Enthusiast
Enthusiast
Posts: 744
Joined: Thu Jun 26, 2003 2:09 am
Location: Spain (Galicia)

Re: Meridians and Parallels

Post by einander »

Updated for PB 5 and added button to show/hide links.

I need advice to replace the links between spheres with CreateCylinder instead of CreateLine3D.
How can a cylinder be aligned knowing the x,y,z positions for the top an bottom?
Thanks in advance.

Code: Select all

;Meridians and Parallels
;by einander
;Adapted to PB 5, small improvements

EnableExplicit
InitEngine3D()
InitKeyboard()
InitSprite()
;
Structure Vector:X.D:Y.D:Z.D:EndStructure
#RADTODEG=180.0/#PI
Global _CamSpeed.D=1,_VCenter.Vector,_Mainmesh,_BtnLink,_Quit
Define Wi,He,I,Siz.Vector
;
Macro GadRGB(Gad,RGB1=$FFFFFF,RGB2=0)
  SetGadgetColor(Gad,1,RGB1)     
  SetGadgetColor(Gad,2,RGB2)   
EndMacro
;
Procedure KeyMap(Node,Cam)  ; Control  moving and rotating with Keyboard
  ; -------
  Macro KBP(Key1,Key2)
    (KeyboardPushed(#PB_Key_#Key1) Or KeyboardPushed(#Pb_Key_#Key2))
  EndMacro
  ; -------
  If KBP(ADD,F1)         
    MoveCamera(Cam, 0,0, -_CamSpeed*2)               ; Move to front
  ElseIf KBP(Subtract,F2)         
    MoveCamera(Cam, 0, 0,_CamSpeed*2)                ; Move to rear
    ; ------------------------------
    ; Arrow keys; move camera to 4  Directions
  ElseIf KeyboardPushed(#PB_Key_Left)             
    MoveNode(Node, _CamSpeed, 0, 0)                  ; Move to screen Left
  ElseIf KeyboardPushed(#PB_Key_Right)             
    MoveNode(Node, -_CamSpeed, 0, 0)                 ; Move to screen Right
  ElseIf KeyboardPushed(#PB_Key_Up)             
    MoveNode(Node, 0,-_CamSpeed, 0)                  ; Move to screen Top
  ElseIf KeyboardPushed(#PB_Key_Down)             
    MoveNode(Node, 0,_CamSpeed, 0)                   ; Move to screen Bottom
    ; -------------------
    ;PageUp - Insert
  ElseIf KBP(F3,PageUp)
    RotateNode(Node,0,0,_CamSpeed*2,#PB_Relative)    ; Turn Left
  ElseIf KBP(F4,Insert)
    RotateNode(Node,0,0,-_CamSpeed*2,#PB_Relative)   ; Turn Right
    ; ---------------------
    ;Home / End     
  ElseIf KBP(F5,Home)
    RotateNode(Node,_CamSpeed,0,0,#PB_Relative)      ; Turn back
  ElseIf KBP(F6,End)
    RotateNode(Node,-_CamSpeed,0,0,#PB_Relative)     ; Turn front
    ; -------------
    ;Delete / PageDown
  ElseIf KBP(F7,Delete)
    RotateNode(Node,0, _CamSpeed,0,#PB_Relative)     ; Rotation Left
  ElseIf KBP(F8,PageDown)
    RotateNode(Node,0,- _CamSpeed,0,#PB_Relative)    ; Rotation Right
  EndIf
EndProcedure
;
Procedure MkSphere(Sph,Merid,Paral,*Siz.Vector)
  RandomSeed(2)
  Paral*2
  Protected.D K, J, XStp=360/Merid, YStp=180/Paral
  Protected N,A,I, RGB,Arrsiz
  Protected Dim Vx.Vector(0)
  Repeat
    K.D=0
    J+YStp
    Repeat
      ReDim Vx(N)
      VX(N)\X =*Siz\X *  Sin((K) / #Radtodeg) * Sin((J) / #Radtodeg)
      VX(N)\Y =*Siz\Y *  Cos((K) / #Radtodeg) * Sin((J) / #Radtodeg)
      VX(N)\Z =*Siz\Z *  Cos((J) / #Radtodeg)
      N+1
      K+XStp
    Until K>=359
    J+YStp
  Until J>=179
  Arrsiz=ArraySize(Vx())
  For I = 0 To Arrsiz
    If I%Merid=0
      RGB=Random($FFFFFF)
    EndIf
    CreateEntity(I,MeshID(Sph),#PB_Material_None,Vx(I)\X,Vx(I)\Y,Vx(I)\Z) ;   parallels
    If I%Merid:    A=I-1
    Else      :    A=I+Merid-1
    EndIf     
    If GetGadgetState(_btnLink)
      CreateLine3D(I,Vx(A)\X,Vx(A)\Y,Vx(A)\Z,RGB,Vx(I)\X,Vx(I)\Y,Vx(I)\Z,RGB)
      If I<Arrsiz-Merid+1   
        A=I+Merid
        CreateLine3D(I+Arrsiz+1,Vx(A)\X,Vx(A)\Y,Vx(A)\Z,RGB,Vx(I)\X,Vx(I)\Y,Vx(I)\Z,RGB) ; meridians
      EndIf
    EndIf  
  Next
  Dim Vx(0)
  ProcedureReturn Arrsiz
EndProcedure
;
; <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Define T$= "Keys: Left, Right, Up, Down, PageUp, PageDown, Insert, Delete, Home, End, +, -, F1 to F8, <Spc> to auto rotation."
OpenWindow(0, 100, 100,700,500 ,T$,  #PB_Window_SystemMenu|#PB_Window_Maximize|#PB_Window_Invisible)
SetWindowColor(0,0)
Wi=WindowWidth(0):He=WindowHeight(0)
Define X1=Wi-200
Siz\X=100:Siz\Y=100:Siz\Z=100
Define Merid=6 ; meridians
Define Paral=4  ;parallels
Define Radius.D=1
Define TBX=TrackBarGadget(-1,X1,10,180,26,0,500)
Define TBY=TrackBarGadget(-1,X1,50,180,26,0,500)
Define TBZ=TrackBarGadget(-1,X1,90,180,26,0,500)
Define SpMerid=SpinGadget(-1,X1,170,80,30,1,100,#PB_Spin_Numeric)
Define SpParal=SpinGadget(-1,X1,210,80,30,1,100,#PB_Spin_Numeric)
_BtnLink=ButtonGadget(-1,x1,250,80,30,"Links",#PB_Button_Toggle)
SetGadgetState(_btnlink,1)
Define TBRadius=TrackBarGadget(-1,X1,130,180,26,0,300)
GadgetToolTip(tbRadius,"Balls radius")
Define TG=TextGadget(-1,0,0, Wi-210,24,"")
Define Draw=1,AutoRotate=1

TextGadget(0,X1+90,170,80,26,"Meridians")
TextGadget(1,X1+90,210,80,26,"Parallels")
GadRGB(0,$FFFFFF,0)
GadRGB(1,$FFFFFF,0)
SetGadgetState(SpMerid,Merid)
SetGadgetState(SpParal,Paral)
SetGadgetState(TBX,Siz\X)   
SetGadgetState(TBY,Siz\Y)   
SetGadgetState(TBZ,Siz\Z)   
GadgetToolTip(tbx,"Size X")
GadgetToolTip(tby,"Size Y")
GadgetToolTip(tbz,"Size Z")
;
SetGadgetState(TbRadius,Radius*10)
GadRGB(Tg,$FFFFFF,0)
HideWindow(0,0)
; ------------------------
AntialiasingMode(#PB_AntialiasingMode_x4)
OpenWindowedScreen(WindowID(0),0,24,X1-10,He,0,0,0,#PB_Screen_SmartSynchronization)
KeyboardMode(#PB_Keyboard_International)
Define Sph=CreateSphere(-1,Radius)
Define Arrsiz=MkSphere(Sph,Merid,Paral,Siz)
;
CreateNode(0,0,0,0)
CreateCamera(0, 0, 0, 100, 100)
CameraLocate(0, 0, 0, 400)
AttachNodeObject(0,CameraID(0))
;
CreateLight(0, $Ddeeff ,-200, 0  ,-100)
CreateLight(1, $Bbccdd , 200, 0  , 100)
CreateLight(2, $FFff   , 0  , 200, 0)
AmbientColor($112233)
Repeat
  Select WindowEvent()
    Case #PB_Event_CloseWindow :_Quit=#True 
    Case #PB_Event_Gadget
      Select EventGadget()
        Case TBX,TBY,TBZ
          Siz\X=GetGadgetState(TBX)   
          Siz\Y=GetGadgetState(TBY)   
          Siz\Z=GetGadgetState(TBZ)   
          Arrsiz=MkSphere(Sph,Merid,Paral,Siz)
          SetActiveGadget(Tg)
          Draw=1
        Case SpMerid,SpParal,_btnlink
          For I=0 To ArrSiz*2
            If IsEntity(I):FreeEntity(I):EndIf
            If IsMesh(I)  :FreeMesh(I)  :EndIf
          Next
          Merid=GetGadgetState(SpMerid)
          Paral=GetGadgetState(SpParal)
          Arrsiz=MkSphere(Sph,Merid,Paral,Siz)
          SetActiveGadget(Tg)
          Draw=1
        Case TbRadius
          Radius=GetGadgetState(TbRadius)/10
          FreeMesh(Sph)
          Sph=CreateSphere(-1,Radius)
          Arrsiz=MkSphere(Sph,Merid,Paral,Siz)
          SetActiveGadget(Tg)
          Draw=1
      EndSelect
    Default
      If ExamineKeyboard() Or Draw
        If KeyboardPushed(#PB_Key_Escape) :_Quit=#True :EndIf
        If KeyboardReleased(#PB_Key_Space):AutoRotate!1:EndIf
        If Draw=0:Keymap(0,0) :EndIf
        Draw=1
      EndIf
  EndSelect
  If AutoRotate Or Draw
    If AutoRotate
      RotateNode(0,0,0,0.2,#PB_Relative)       
      RotateNode(0,0,0.5,0,#PB_Relative)       
      Draw=1
    EndIf
    RenderWorld()
    FlipBuffers()
    Draw=0
  EndIf
Until  _Quit
End
User avatar
Psychophanta
Always Here
Always Here
Posts: 5153
Joined: Wed Jun 11, 2003 9:33 pm
Location: Anare
Contact:

Re: Meridians and Parallels

Post by Psychophanta »

)-)i

Can not run it; after a clean installation of the PB5.00B3 i get "Invalid memory address" error at line 140 (Antialiasingmode function)
http://www.zeitgeistmovie.com

while (world==business) world+=mafia;
User avatar
einander
Enthusiast
Enthusiast
Posts: 744
Joined: Thu Jun 26, 2003 2:09 am
Location: Spain (Galicia)

Re: Meridians and Parallels

Post by einander »

Tested with P 5.00 beta 3, win seven 32 and seven 64.
Also with antialiasing mode_x2 and _x6, and with line 140 commented, and always works.
Somebody had noticed the same (or another) error?
yrreti
Enthusiast
Enthusiast
Posts: 546
Joined: Tue Oct 31, 2006 4:34 am

Re: Meridians and Parallels

Post by yrreti »

Hi einander
No problem here with XP Pro and PB5b3, and still looks really neat.
I just wish this could some how be added in and used as a screen saver.

Thanks
User avatar
Psychophanta
Always Here
Always Here
Posts: 5153
Joined: Wed Jun 11, 2003 9:33 pm
Location: Anare
Contact:

Re: Meridians and Parallels

Post by Psychophanta »

Tested here with xppro 32 bit with PB4.60, 4.61, 4.70b1 and 5.00b3, and got same bahaviour.
ATI vga.
PB bug?
http://www.zeitgeistmovie.com

while (world==business) world+=mafia;
Post Reply