Superellipses / Supershapes on the fly

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
stef
Posts: 2
Joined: Mar 31, 2007 20:01

Superellipses / Supershapes on the fly

Postby stef » Mar 31, 2007 20:11

Hi all!

I'm new here and found a lot of interesting stuff and postings!
Thx for sharing!

Maybe these 2 (beginner) codes are interesting for somebody

Code: Select all

' Superellipses/Supershapes on the fly
' by stef
   
    OPTION STATIC
    OPTION EXPLICIT

   
    CONST SCREENW=800 '640                  
    CONST SCREENH=600 '480                  
    CONST MAXSHAPES=100
 
    declare sub initshapes()
    declare sub calcshapes()
    declare sub drawshapes()

    dim shared rad as single
    dim shared rot as single
    dim shared dist as single
    dim status as integer
    dim time2 as single

type tshapes
    originx as single 
    originy as single
    xradius as single
    yradius as single
    p as single
    dp as single
    rotangle as single
    drotangle as single
    col as integer
   
    posx1(36) as single
    posy1(36) as single
    rotposx as single
    rotposy as single
   
end type

    dim shared shape(MAXSHAPES) as tshapes


 
    SCREEN 19, 16, 2, 1
   
    SCREENSET 1, 0

    time2=timer

    RANDOMIZE TIMER

   

DO
   
    CLS
   
    if status = 0 then
        initshapes()
        status=1
    endif
   

    IF MULTIKEY(&h39) then
        status=0
    endif
   
    calcshapes()
 
    drawshapes()
   
    locate 1,1,0
    print "hit space"
   
    'if timer-time2>0.033 then
        time2=timer
        SCREENCOPY
   ' endif

   
LOOP UNTIL INKEY$=CHR$(27)

sub initshapes()
    dim x as integer
   
    for x= 0 to MAXSHAPES
        shape(x).originx=Rnd*SCREENW 
        shape(x).originy=Rnd*SCREENH
        shape(x).xradius=Rnd*80+20
        shape(x).yradius=Rnd*80+20
        shape(x).p=rnd*4
        shape(x).dp=rnd*0.1
        shape(x).rotangle=Rnd*360
        shape(x).drotangle=(Rnd*2)-1
     
        shape(x).col=rgb(rnd*255,rnd*255,rnd*255)
    next
end sub

sub calcshapes()
    dim a as integer
    dim ang as integer
    dim x as single
    dim y as single
   
    for a= 0 to MAXSHAPES
     
        For ang= 0 To 36
     
            rad=ang*0.17453293 '10 * PI / 180
 
            x=Cos(rad)
            y=sin(rad)
 
            shape(a).posx1(ang)=sgn(x)*shape(a).xradius*(Abs(x)^shape(a).p)
            shape(a).posy1(ang)=sgn(y)*shape(a).yradius*(Abs(y)^shape(a).p)
 
   
            rot=atan2((shape(a).originx-(shape(a).originx+shape(a).posx1(ang))),(shape(a).originy-(shape(a).originy+shape(a).posy1(ang))))
            dist= Sqr ( (shape(a).originx-(shape(a).originx+shape(a).posx1(ang)))^2 + (shape(a).originy-(shape(a).originy+shape(a).posy1(ang)))^2 )
 
            shape(a).posx1(ang)=dist*Cos((shape(a).rotangle) * 0.17453293-rot)
            shape(a).posy1(ang)=dist*Sin((shape(a).rotangle) * 0.17453293-rot)
 
        next
 
        shape(a).rotangle=shape(a).rotangle+shape(a).drotangle
 
        shape(a).p=shape(a).p+shape(a).dp
       
        if shape(a).p> 5 then
            shape(a).dp=-shape(a).dp
        endif
   
        if shape(a).p< 0 then
            shape(a).p=0
            shape(a).dp=-shape(a).dp 
        endif
 
    next

end sub

sub drawshapes()
    dim a as integer
    dim ang as integer
 
    for a= 0 to MAXSHAPES
        For ang= 0 To 36
         
        If ang<36 then
            Line (shape(a).originx+shape(a).posx1(ang),shape(a).originy+shape(a).posy1(ang))-(shape(a).originx+shape(a).posx1(ang+1),shape(a).originy+shape(a).posy1(ang+1) ),shape(a).col
 
        endif   
         
 
        next
        paint  (shape(a).originx,shape(a).originy) ,shape(a).col,shape(a).col
     
    next
end sub
   
   




Code: Select all


' Superbird on the fly
' 23.01.07
' by stef
   
    OPTION STATIC
    OPTION EXPLICIT

   
    CONST SCREENW=800 '640                  
    CONST SCREENH=600 '480                  
   
 

    dim ang as integer
    dim ang2 as single
    dim radang2 as single
    dim sinang2 as single
    dim cosang2 as single
    dim rad as single
    dim x as single
    dim y as single
    dim posx as single
    dim posy as single
    dim p as single
    dim q as single
   
   
    dim col_red as integer =255
    dim col_green as integer
    dim col_blue as integer
    dim colfactor as integer =1
   
   
    dim time2 as single


 
    SCREEN 19, 16, 2, 1
   
    SCREENSET 1, 0

    time2=timer

    RANDOMIZE TIMER

 
DO
   
    CLS
   
    For ang= 0 To 36000
     
            rad=ang*0.017453293
   
        x=Cos(rad)
        y=sin(rad)
 
        posx=sgn(x)*400*(Abs(x)^p)
        posy=sgn(y)*300*(Abs(y)^p)
       
       
        If (ang>45) And (ang<91) then
           
            If col_red<255 And col_blue =255 And col_green =0 Then col_red=col_red+colfactor
            If col_red=255 And col_blue >0 And col_green=0 Then   col_blue=col_blue-colfactor
            If col_red=255 And col_blue =0 And col_green < 255 Then col_green=col_green+colfactor
            If col_red>0 And col_blue =0 And col_green = 255 Then col_red=col_red-colfactor
            If col_red=0 And col_blue <255 And col_green = 255 Then col_blue=col_blue+colfactor      
            If col_red=0 And col_blue =255 And col_green >0 Then col_green=col_green-colfactor
           
 
              Line (360-20*cosang2,320-10*sinang2)-((400+5*cosang2)+posx,(20+5*sinang2)+posy),rgb(col_red,col_green,col_blue)
              Line (360-20*cosang2,320-10*sinang2)-((400+5*cosang2)-posx,(20+5*sinang2)+posy),rgb(col_red,col_green,col_blue)
         Endif
   
    next
   

       
   p=p+0.1*q
   If p<0.8  then
       q=1.0
      p=0.8
    EndIf
   
    If p>=4 Then
        q=-1.0
   
    endif
   
    ang2=ang2+2
    If ang2>360 Then ang2=0
    sinang2=sin(ang2*0.017453293)
   cosang2=cos(ang2*0.017453293)
   
   
   
    'if timer-time2>0.016 then  'fps 60 ??
        time2=timer
        SCREENCOPY
    'endif

   
LOOP UNTIL INKEY$=CHR$(27)


relsoft
Posts: 1767
Joined: May 27, 2005 10:34
Location: Philippines
Contact:

Postby relsoft » Apr 01, 2007 4:40

Nice!!!
E.K.Virtanen
Posts: 785
Joined: May 28, 2005 9:19
Location: Finland

Postby E.K.Virtanen » Apr 04, 2007 15:41

Both are nice ones. Loved specially second code.

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 4 guests