2D graphx function Star()

Share your advanced PureBasic knowledge/code with the community.
Post Reply
User avatar
Psychophanta
Addict
Addict
Posts: 4996
Joined: Wed Jun 11, 2003 9:33 pm
Location: Lípetsk, Russian Federation
Contact:
Contact Psychophanta

2D graphx function Star()

Post by Psychophanta »

Code updated For 5.20+

Code: Select all

Procedure Star(x.l,y.l,intrad.l,extrad.l,n.l,inclination.l,phase.f,color.l)
  alpha.f=2*#PI/n
  i.f=inclination/20-1/2
  For t.l=1 To n:d1.f=(t-1)*alpha+phase:d2.f=t*alpha+phase:d3.f=(t+i)*alpha+phase
    LineXY(x+intrad*Cos(d1),y+intrad*Sin(d1),x+extrad*Cos(d3),y+extrad*Sin(d3),color)
    LineXY(x+intrad*Cos(d2),y+intrad*Sin(d2),x+extrad*Cos(d3),y+extrad*Sin(d3),color)
  Next
EndProcedure
http://www.zeitgeistmovie.com

While world=business:world+mafia:Wend
Will never leave this forum until the absolute bugfree PB :mrgreen:
Top
User avatar
Psychophanta
Addict
Addict
Posts: 4996
Joined: Wed Jun 11, 2003 9:33 pm
Location: Lípetsk, Russian Federation
Contact:
Contact Psychophanta

Re: 2D graphx function Star()

Post by Psychophanta »

Correct name for the function should be "Regular polygon function".

Test it:

Code: Select all

; DrawStar function:
; Author: Psychophanta
; Date: 5 Nov 2004
;Ported to PB4.0 5 Feb 2006

;-INITS:
Global bitplanes.b=32,RX.w=GetSystemMetrics_(#SM_CXSCREEN),RY.w=GetSystemMetrics_(#SM_CYSCREEN),r1.l=70,r2.l=90,p.l=3,incl.f=0.0
If InitMouse()=0 Or InitSprite()=0 Or InitKeyboard()=0
  MessageRequester("Error","Can't access DirectX",0)
  End
EndIf
While OpenScreen(RX.w,RY.w,bitplanes.b,"")=0
  If bitplanes.b>16:bitplanes.b-8
  ElseIf RY.w>600:RX.w=800:RY.w=600
  ElseIf RY.w>480:RX.w=640:RY.w=480
  ElseIf RY.w>400:RX.w=640:RY.w=400
  ElseIf RY.w>240:RX.w=320:RY.w=240
  ElseIf RY.w>200:RX.w=320:RY.w=200
  Else:MessageRequester("VGA","Can't open Screen!",0):End
  EndIf
Wend

Procedure DrawStar(x.l,y.l,intrad.l,extrad.l,n.l,inclination.l,phase.f,color.l)
  Protected alpha.f=2*#PI/n,i.d=inclination/20-1/2,t.l,d1.f,d2.f,d3.f
  For t.l=1 To n:d1.f=(t-1)*alpha+phase:d2.f=t*alpha+phase:d3.f=(t+i)*alpha+phase
    LineXY(x+intrad*Cos(d1),y+intrad*Sin(d1),x+extrad*Cos(d3),y+extrad*Sin(d3),color)
    LineXY(x+intrad*Cos(d2),y+intrad*Sin(d2),x+extrad*Cos(d3),y+extrad*Sin(d3),color)
  Next
EndProcedure

;-MAIN:
MouseLocate(333,333)
Repeat
  ClearScreen(0)
  ExamineKeyboard()
  ExamineMouse():mx.l=MouseX():my.l=MouseY()
  StartDrawing(ScreenOutput())
  DrawStar(RX/2,RY/2,r1.l,r2.l,p,incl,pha.f,$aaaaaa)
  pha+MouseDeltaX()*0.01:r2-MouseDeltaY()
  If MouseButton(1):While MouseButton(1):Delay(16):ExamineMouse():Wend
    p+1:If p>80:p=80:EndIf
  ElseIf MouseButton(2):While MouseButton(2):Delay(16):ExamineMouse():Wend
    p-1:If p<2:p=2:EndIf
  EndIf
  If KeyboardPushed(#PB_Key_Z)
    incl-0.3
  ElseIf KeyboardPushed(#PB_Key_X)
    incl+0.3
  EndIf
  StopDrawing()
  FlipBuffers():Delay(16)
Until KeyboardPushed(#PB_Key_Escape)
Modified code and function for vectorial drawing lib:

Code: Select all

; Vectorial DrawStar function:
; Author: Psychophanta
; Date: May 2017

Global bitplanes.b=32,RX.w=GetSystemMetrics_(#SM_CXSCREEN),RY.w=GetSystemMetrics_(#SM_CYSCREEN),rix.w=400,riy.w=225,r1.l=40,r2.l=60,p.l=3,incl.f=0.0
If InitMouse()=0 Or InitSprite()=0 Or InitKeyboard()=0
  MessageRequester("Error","Can't access DirectX",0)
  End
EndIf
While OpenScreen(RX.w,RY.w,bitplanes.b,"")=0
  If bitplanes.b>16:bitplanes.b-8
  ElseIf RY.w>600:RX.w=800:RY.w=600
  ElseIf RY.w>480:RX.w=640:RY.w=480
  ElseIf RY.w>400:RX.w=640:RY.w=400
  ElseIf RY.w>240:RX.w=320:RY.w=240
  ElseIf RY.w>200:RX.w=320:RY.w=200
  Else:MessageRequester("VGA","Can't open Screen!",0):End
  EndIf
Wend

Procedure DrawStar(x.l,y.l,intrad.l,extrad.l,n.l,inclination.f,phase.f,color.l=$AAAAAAAA,filled.b=0)
  Protected alpha.f=2*#PI/n,i.f=inclination/20-1/2,t.u,d1.f,d2.f
  MovePathCursor(x+intrad*Cos(phase),y+intrad*Sin(phase))
  For t.u=1 To n:d2.f=t*alpha+phase:d1.f=(t+i)*alpha+phase
    AddPathLine(x+extrad*Cos(d1),y+extrad*Sin(d1),#PB_Path_Default)
    AddPathLine(x+intrad*Cos(d2),y+intrad*Sin(d2),#PB_Path_Default)
  Next
  VectorSourceColor(color)
  If filled
    FillPath(#PB_Path_Default)
  Else
    StrokePath(1,#PB_Path_RoundCorner)
  EndIf
EndProcedure

Procedure clearimage(a.i,col.l)
  StartDrawing(ImageOutput(a))
  Box(0,0,ImageWidth(a),ImageHeight(a),col)
  StopDrawing()
EndProcedure

CreateImage(0,rix,riy,bitplanes,$000000)

;-MAIN:
MouseLocate(33,33)
Repeat
  clearimage(0,$11111111)
  ExamineKeyboard()
  ExamineMouse():mx.l=MouseX():my.l=MouseY()
  StartVectorDrawing(ImageVectorOutput(0,#PB_Unit_Pixel))
  DrawStar(rix/2,riy/2,r1.l,r2.l,p,incl,pha.f,$778899aa,1)
  pha+MouseDeltaX()*0.01:r2-MouseDeltaY()
  If MouseButton(#PB_MouseButton_Left):While MouseButton(1):Delay(16):ExamineMouse():Wend
    p+1:If p>80:p=80:EndIf
  ElseIf MouseButton(#PB_MouseButton_Right):While MouseButton(2):Delay(16):ExamineMouse():Wend
  p-1:If p<2:p=2:EndIf
  EndIf
  If KeyboardPushed(#PB_Key_Z)
    incl-0.3
  ElseIf KeyboardPushed(#PB_Key_X)
    incl+0.3
  EndIf
  StopVectorDrawing()
  StartDrawing(ScreenOutput())
  DrawImage(ImageID(0),0,0,RX,RY)
  StopDrawing()
  FlipBuffers():Delay(15)
Until KeyboardPushed(#PB_Key_Escape)
A remember code with a similar function i called DrawCogged2D():

Code: Select all

; Author: Psychophanta
; Date: 18 Jan 2011
;PB4.51

;-INITS:
Define .d
bitplanes.b=32:RX.l=GetSystemMetrics_(#SM_CXSCREEN):RY.l=GetSystemMetrics_(#SM_CYSCREEN)
If InitMouse()=0 Or InitSprite()=0 Or InitKeyboard()=0
  MessageRequester("Error","Can't access DirectX",0)
  End
EndIf
While OpenScreen(RX,RY,bitplanes.b,"")=0
  If bitplanes.b>16:bitplanes.b-8
  ElseIf RY>600:RX=800:RY=600
  ElseIf RY>480:RX=640:RY=480
  ElseIf RY>400:RX=640:RY=400
  ElseIf RY>240:RX=320:RY=240
  ElseIf RY>200:RX=320:RY=200
  Else:MessageRequester("VGA","Can't open Screen!",0):End
  EndIf
Wend
Procedure.d myATan2(y.d,x.d)
  !fld qword[p.v_y]
  !fld qword[p.v_x]
  !fpatan
  ProcedureReturn
EndProcedure
Procedure DrawCogged2D(x.d,y.d,intrad.d,extrad.d,n.l,phase.d,color.l,x2.d,y2.d,color2.l)
  If n<2:n=2:EndIf:If intrad<1:intrad=1:EndIf:If extrad<1:extrad=1:EndIf:phase=Mod(phase,#PI)
  Protected dx.d=x2-x,dy.d=y2-y,d.d=Sqr(dx*dx+dy*dy)
  If d>extrad
    Protected alfa.d=2*#PI/n,t.l,d1.d,d2.d,d3.d
    For t=1 To n:d1=(t-1)*alfa+phase:d2=t*alfa+phase:d3=(t-0.5)*alfa+phase
      LineXY(x+intrad*Cos(d1),y+intrad*Sin(d1),x+extrad*Cos(d3),y+extrad*Sin(d3),color)
      LineXY(x+intrad*Cos(d2),y+intrad*Sin(d2),x+extrad*Cos(d3),y+extrad*Sin(d3),color)
    Next
    Protected intrad2.d=d-extrad,extrad2.d=d-intrad
    Protected A.d=extrad/extrad2; <- gear ratio
    n/A
    alfa=#PI/n
    Protected phase2.d=#PI+alfa-A*phase+myATan2(dy,dx)*(A+1)
    alfa*2
    For t=1 To n:d1=(t-1)*alfa+phase2:d2=t*alfa+phase2:d3=(t-0.5)*alfa+phase2
      LineXY(x2+intrad2*Cos(d1),y2+intrad2*Sin(d1),x2+extrad2*Cos(d3),y2+extrad2*Sin(d3),color2)
      LineXY(x2+intrad2*Cos(d2),y2+intrad2*Sin(d2),x2+extrad2*Cos(d3),y2+extrad2*Sin(d3),color2)
    Next
  EndIf
EndProcedure

r1.l=70:r2.l=90:p.l=18:x1=RX/2:y1=RY/2:x2=0.66*RX:y2=0.76*RY
;-MAIN:
MouseLocate(333,333)
Repeat
  ClearScreen(0)
  ExamineKeyboard()
  ExamineMouse():mx.l=MouseX():my.l=MouseY()
  StartDrawing(ScreenOutput())
  DrawCogged2D(x1,y1,r1.l,r2.l,p,pha,$aaaaaa,x2,y2,$23b367)
  If KeyboardPushed(#PB_Key_LeftControl)
    If MouseButton(1):Repeat:Delay(16):ExamineMouse():Until MouseButton(1)=0
      p+1:If p>80:p=80:EndIf
    EndIf
    If MouseButton(2):Repeat:Delay(16):ExamineMouse():Until MouseButton(2)=0
      p-1:If p<2:p=2:EndIf
    EndIf
  Else
    pha=Mod(pha+MouseDeltaX()*0.01,#PI)
    If MouseButton(1)
      x1=Mod(x1+MouseDeltaX(),RX)
      y1=Mod(y1+MouseDeltaY(),RY)
    ElseIf MouseButton(2)
      x2=Mod(x2+MouseDeltaX(),RX)
      y2=Mod(y2+MouseDeltaY(),RY)
    EndIf
  EndIf
  StopDrawing()
  FlipBuffers():Delay(16)
Until KeyboardPushed(#PB_Key_Escape)
http://www.zeitgeistmovie.com

While world=business:world+mafia:Wend
Will never leave this forum until the absolute bugfree PB :mrgreen:
Top
Post Reply

Return to “Tricks 'n' Tips”