Support Forum / Форум поддержки

Mr.Kibernetik software support
https://nitisara.ru/forum/

3d morphing dot demo

https://nitisara.ru/forum/viewtopic.php?f=20&t=1570

Page 1 of 1

3d morphing dot demo

Posted: Sun Oct 16, 2016 9:24 am
by DrChip

Code: Select all

REM morphing dot demo
REM sB 6.0 / ioS 10.1 beta 3 / iPhone 6+
REM enjoy...

GOSUB initialize


main_loop:
  REFRESH OFF
  GRAPHICS CLEAR 0,0,0

  GOSUB process_input
  GOSUB draw_stars
  GOSUB display_name
  GOSUB display_scroller
  GOSUB morph
  GOSUB rotchange
  GOSUB cycle_color
  REFRESH
GOTO main_loop

display_scroller:
 DRAW COLOR 1,1,1
 mx=mx-2
 IF mx<=0 THEN 
  mx=mx+10
  mpos=mpos+1
  IF mpos>LEN(m$)-1 THEN
   mpos=0
  END IF
 END IF

 DRAW TEXT MID$(m$,mpos,64) AT mx,sh-20
 FILL COLOR 0,0,0
 FILL RECT 0,490 TO 10,512
RETURN


display_name:
 IF textlife<=0 THEN RETURN 

 textlife=textlife-5
 DRAW COLOR textlife/255,textlife/255,textlife/255
 DRAW TEXT NAME$ AT 0,20
RETURN


cycle_color:
 IF red=tred AND green=tgreen AND blue=tblue THEN
  tred=INT(RND(100))/100
  tblue=INT(RND(100))/100
  tgreen=INT(RND(100))/100
  RETURN
 END IF

 IF red<tred THEN
  red=red+0.01
  IF red>tred THEN
   red=tred
  END IF
 END IF

 IF red>tred THEN
  red=red-0.01
  IF red<tred THEN
   red=tred
  END IF
 END IF

 IF green<tgreen THEN
  green=green+0.01
  IF green>tgreen THEN
   green=tgreen
  END IF
 END IF

 IF green>tgreen THEN
  green=green-0.01
  IF green<tgreen THEN
   green=tgreen
  END IF
 END IF

 IF blue<tblue THEN
  blue=blue+0.01
  IF blue>tblue THEN
   blue=tblue
  END IF
 END IF

 IF blue>tblue THEN
  blue=blue-0.01
  IF blue<tblue THEN
   blue=tblue
  END IF
 END IF
RETURN

rotchange:
 xrot=xrot+xroto
 IF xrot<0 THEN xrot=xrot+360 
 IF xrot>360 THEN xrot=xrot-360 

 yrot=yrot+yroto
 IF yrot<0 THEN yrot=yrot+360 
 IF yrot>360 THEN yrot=yrot-360 

 zrot=zrot+zroto
 IF zrot<0 THEN zrot=zrot+360 
 IF zrot>360 THEN zrot=zrot-360 
RETURN


process_input:

IF BUTTON_PRESSED("press") THEN
  xroto=0!yroto=0!zroto=0
END IF 
IF BUTTON_PRESSED("up") THEN
 yroto=yroto-1
END IF
IF BUTTON_PRESSED("down") THEN
 yroto=yroto+1
END IF 
IF BUTTON_PRESSED("left") THEN
 xroto=xroto-1
END IF 
IF BUTTON_PRESSED("right") THEN
xroto=xroto+1
END IF
IF BUTTON_PRESSED("in") AND zroto>-offmax THEN
zroto=zroto-1
END IF
IF BUTTON_PRESSED("out") AND zroto<offmax THEN
zroto=zroto+1
END IF
RETURN

draw_stars:
 focus=2000

 FOR star=1 TO numstars
  x=starx(star)
  y=stary(star)
  z=starz(star)

  REM x rotation
  xx=x
  yy=y*cosines(xrot)+z*sines(xrot)
  zz=z*cosines(xrot)-y*sines(xrot)

  REM y rotation
  x=xx*cosines(yrot)-zz*sines(yrot)
  y=yy
  z=xx*sines(yrot)+zz*cosines(yrot)

  REM z rotation
  xx=x*cosines(zrot)-y*sines(zrot)
  yy=x*sines(zrot)+y*cosines(zrot)
  zz=z

  REM perspective transformation
  xx=xx/((zz/focus)+1)
  yy=yy/((zz/focus)+1)

  brightnesss=128-(zz/2)
  sizes=brightnesss/20
  FILL COLOR red*brightnesss/255,green*brightnesss/255,blue*brightnesss/255
  FILL RECT ox+xx,oy+yy TO ox+xx+sizes,oy+yy+sizes

 NEXT star
RETURN

setup_shapes:

 DIM shapes(numshapes+1,numstars+1,4)
 DIM shapename$(numshapes+1)

 shapename$(1)="Pyramids"
 FOR a=1 TO 20
  shapes(1,a,1)=(a*10)-100
  shapes(1,a,2)=-100
  shapes(1,a,3)=-100

  shapes(1,a+20,1)=(a*5)-100
  shapes(1,a+20,2)=-100
  shapes(1,a+20,3)=(a*10)-100

  shapes(1,a+40,1)=(a*5)
  shapes(1,a+40,2)=-100
  shapes(1,a+40,3)=((10-a)*10)

  shapes(1,a+60,1)=(a*5)-100
  shapes(1,a+60,2)=(a*10)-100
  shapes(1,a+60,3)=(a*5)-100

  shapes(1,a+80,1)=(a*5)
  shapes(1,a+80,2)=((10-a)*10)
  shapes(1,a+80,3)=((10-a)*5)-50

  shapes(1,a+100,1)=0
  shapes(1,a+100,2)=((10-a)*10)
  shapes(1,a+100,3)=(a*5)
 NEXT a
 FOR a=1 TO 5
  shapes(1,a+120,1)=(a*10)-25
  shapes(1,a+120,2)=-25
  shapes(1,a+120,3)=-25

  shapes(1,a+125,1)=(a*5)-25
  shapes(1,a+125,2)=-25
  shapes(1,a+125,3)=(a*10)-25

  shapes(1,a+130,1)=(a*5)
  shapes(1,a+130,2)=-25
  shapes(1,a+130,3)=((6-a)*10)-25

  shapes(1,a+135,1)=(a*5)-25
  shapes(1,a+135,2)=(a*10)-25
  shapes(1,a+135,3)=(a*5)-25

  shapes(1,a+140,1)=(a*5)
  shapes(1,a+140,2)=((6-a)*10)-25
  shapes(1,a+140,3)=((6-a)*5)-25

  shapes(1,a+145,1)=0
  shapes(1,a+145,2)=((6-a)*10)-25
  shapes(1,a+145,3)=(a*5)
 NEXT a

 shapename$(2)="Coiled spring"
 FOR a=1 TO numstars
  shapes(2,a,1)=INT(SIN((a*14)*(pi/180))*200)
  shapes(2,a,2)=INT(COS((a*14)*(pi/180))*200)
  shapes(2,a,3)=INT(COS((a)*(pi/180))*200)
 NEXT a

 shapename$(3)="Bendy strip"
 FOR a=1 TO numstars
  shapes(3,a,1)=INT(SIN((a)*(pi/180))*SIN((a)*(pi/180))*200)
  shapes(3,a,2)=INT(SIN((a)*(pi/180))*COS((a)*(pi/180))*200)
  shapes(3,a,3)=INT(COS((a)*(pi/180))*200)
 NEXT a

 shapename$(4)="Bent infinity"
 FOR a=1 TO numstars
  shapes(4,a,1)=INT(SIN((a*2.5)*(pi/180))*SIN((a*2.5)*(pi/180))*200)
  shapes(4,a,2)=INT(SIN((a*2.5)*(pi/180))*COS((a*2.5)*(pi/180))*200)
  shapes(4,a,3)=INT(COS((a*2.5)*(pi/180))*200)
 NEXT a

 shapename$(5)="Ring sphere"
 long=0
 latt=0
 FOR a=1 TO numstars
  IF long>360 THEN
   long=long-360
   latt=latt+15
  END IF
  shapes(5,a,1)=INT(SIN(long*(pi/180))*SIN(latt*(pi/180))*200)
  shapes(5,a,2)=INT(SIN(long*(pi/180))*COS(latt*(pi/180))*200)
  shapes(5,a,3)=INT(COS(long*(pi/180))*200)
  long=long+30
 NEXT a

 shapename$(6)="One ring to show them all"
 FOR a=1 TO numstars
  shapes(6,a,1)=INT(SIN((a*2.5)*(pi/180))*200)
  shapes(6,a,2)=INT(COS((a*2.5)*(pi/180))*200)
  shapes(6,a,3)=0
 NEXT a

 shapename$(7)="Random sphere"
 FOR a=1 TO numstars
  long=INT(RND(360))
  latt=INT(RND(360))
  shapes(7,a,1)=INT(SIN(long*(pi/180))*SIN(latt*(pi/180))*200)
  shapes(7,a,2)=INT(SIN(long*(pi/180))*COS(latt*(pi/180))*200)
  shapes(7,a,3)=INT(COS(long*(pi/180))*200)
 NEXT a
 
 shapename$(8)="Rod"
 FOR a=1 TO numstars
  shapes(8,a,1)=INT(SIN((a*2)*(pi/180))*200)
  shapes(8,a,2)=INT(SIN((a*2)*(pi/180))*200)
  shapes(8,a,3)=0
 NEXT a

 shapename$(9)="Big box"
 FOR a=1 TO numstars
  x=INT(a%5)
  y=INT(a/5%5)
  z=INT(a/25%5)
  shapes(9,a,1)=x*80-160
  shapes(9,a,2)=y*80-160
  shapes(9,a,3)=z*80-160
 NEXT a

 shapename$(10)="The sun"
 FOR a=1 TO numstars
  r=200-((a%5)*20)
  shapes(10,a,1)=INT(SIN((a*2.5)*(pi/180))*r)
  shapes(10,a,2)=INT(COS((a*2.5)*(pi/180))*r)
  shapes(10,a,3)=0
 NEXT a

 shapename$(11)="Crop circles"
 FOR a=1 TO numstars
  r=200-((a%5)*40)
  shapes(11,a,1)=INT(SIN((a*2.5)*(pi/180))*r)
  shapes(11,a,2)=INT(COS((a*2.5)*(pi/180))*r)
  shapes(11,a,3)=0
 NEXT a

 shapename$(12)="Clover"
 FOR a=1 TO numstars
  r=COS((a*5)*(pi/180))*200
  shapes(12,a,1)=INT(SIN((a*2.5)*(pi/180))*r)
  shapes(12,a,2)=INT(COS((a*2.5)*(pi/180))*r)
  shapes(12,a,3)=0
 NEXT a

 shapename$(13)="Flower"
 FOR a=1 TO numstars
  r=COS((a*10)*(pi/180))*200
  shapes(13,a,1)=INT(SIN((a*2.5)*(pi/180))*r)
  shapes(13,a,2)=INT(COS((a*2.5)*(pi/180))*r)
  shapes(13,a,3)=0
 NEXT a

 shapename$(14)="Double headed flower"
 FOR a=1 TO numstars
  r=COS((a*10)*(pi/180))*200
  shapes(14,a,1)=INT(SIN((a*2.5)*(pi/180))*r)
  shapes(14,a,2)=INT(COS((a*2.5)*(pi/180))*r)
  shapes(14,a,3)=r
 NEXT a

 shapename$(15)="Double twist loop"
 FOR a=1 TO numstars
  r=COS((a*5)*(pi/180))*200
  shapes(15,a,1)=INT(SIN((a*2.5)*(pi/180))*r)
  shapes(15,a,2)=INT(COS((a*2.5)*(pi/180))*r)
  shapes(15,a,3)=r
 NEXT a

 shapename$(16)="Folded circle"
 FOR a=1 TO numstars
  z=INT(COS((a*5)*(pi/180))*200)
  IF z>0 THEN z=0 
  shapes(16,a,1)=INT(SIN((a*5)*(pi/180))*200)
  shapes(16,a,2)=INT(COS((a*5)*(pi/180))*200)
  shapes(16,a,3)=z
 NEXT a

 shapename$(17)="Clamshell"
 FOR a=1 TO numstars
  z=INT(COS((a*2.5)*(pi/180))*200)
  IF z>0 THEN z=0 
  shapes(17,a,1)=INT(SIN((a*5)*(pi/180))*200)
  shapes(17,a,2)=INT(COS((a*5)*(pi/180))*200)
  shapes(17,a,3)=z
 NEXT a

 shapename$(18)="Table (or upside down crown)"
 FOR a=1 TO numstars
  z=INT(COS((a*20)*(pi/180))*200)
  IF z>0 THEN z=0 
  shapes(18,a,1)=INT(SIN((a*5)*(pi/180))*200)
  shapes(18,a,2)=INT(COS((a*5)*(pi/180))*200)
  shapes(18,a,3)=z
 NEXT a
RETURN


'Details : This routine sets the target x,y,z
'coords for each star based on the
'target shape.

set_target:
 FOR a=1 TO numstars
  startx(a)=shapes(targetshape,a,1)
  starty(a)=shapes(targetshape,a,2)
  startz(a)=shapes(targetshape,a,3)
 NEXT a
RETURN


'Details : This routine does the actual 
' morphing of the shape.  It's very
' simple really.  It just looks at
' each star and works out if it needs
' moving.  When none need moving, it
' counts down a simple counter and 
' then picks a new shape to morph to.

morph:
 change=0
 FOR a=1 TO numstars
  x=starx(a)!tx=startx(a)
  y=stary(a)!ty=starty(a)
  z=starz(a)!tz=startz(a)

  IF x<tx THEN
   x=x+changespeed
   IF x>tx THEN x=tx 
   change=1
  END IF
  IF x>tx THEN
   x=x-changespeed
   IF x<tx THEN x=tx 
   change=1
  END IF

  IF y<ty THEN
   y=y+changespeed
   IF y>ty THEN y=ty 
   change=1
  END IF
  IF y>ty THEN
   y=y-changespeed
   IF y<ty THEN y=ty 
   change=1
  END IF

  IF z<tz THEN
   z=z+changespeed
   IF z>tz THEN z=tz 
   change=1
  END IF
  IF z>tz THEN
   z=z-changespeed
   IF z<tz THEN z=tz 
   change=1
  END IF

  starx(a)=x
  stary(a)=y
  starz(a)=z
 NEXT a

  IF change=0 THEN
   IF NAME$="" THEN
    NAME$=shapename$(targetshape)
    textlife=500
   END IF
   changewait=changewait-1
   IF changewait<=0 THEN
    NAME$=""
    changewait=changedelay
    targetshape=targetshape+1
    IF targetshape>numshapes THEN
     targetshape=1
    END IF
    GOSUB set_target
   END IF
  END IF
RETURN


setup_message:
 m$="                                                 "
 m$=m$&"                    "
 m$=m$&"Welcome to the DrChip's morphing dot demo.  You can rotate "
 m$=m$&"the shapes by using the joypad on the screen Press "
 m$=m$&"left and right to rotate the shape around the Y "
 m$=m$&"axis, press up and down to rotate the shape "
 m$=m$&"around the X axis, and use < and > to rotate "
 m$=m$&"the shape around the Z axis.  "
 m$=m$&"You can stop the rotation by pressing the square "
 m$=m$&" center button.  "
 m$=m$&"demo.  "
 m$=m$&"The shape morphs between "&STR$(numshapes)
 m$=m$&" preset shapes.  "
 m$=m$&"You can add your own shapes by increasing the "
 m$=m$&"numshapes variable in the initialise routine ("
 m$=m$&"at the end of the code) and by adding your own "
 m$=m$&"bit of code in the setup_shapes routine.  Oh, "
 m$=m$&"and don't forget to give your shape a name.  "
 m$=m$&"You may have noticed that this demo doesn't run "
 m$=m$&"at full speed.  This is hardly surprising.  "
 m$=m$&"There are "&STR$(numstars)&" dots in the demo.  "
 
RETURN

initialize:
GRAPHICS
 sw=SCREEN_WIDTH()
 sh=SCREEN_HEIGHT()
 ox=sw/2
 oy=sh/2
 curbuf=0
 
 pi=3.1415
 numstars=150
 numshapes=18
 targetshape=1
 changespeed=3
 changedelay=200
 changewait=changedelay
 NAME$=""
 textlife=0
 mx=10
 mpos=0

 red=1!blue=1!green=1
 tred=1!tblue=0!tgreen=0
 GOSUB drawpad
 GOSUB setup_message

 DIM starx(numstars+5)
 DIM stary(numstars+5)
 DIM starz(numstars+5)

 DIM startx(numstars+5)
 DIM starty(numstars+5)
 DIM startz(numstars+5)

 DIM cosines(361)
 DIM sines(361)
 FOR ANGLE=0 TO 360
  cosines(ANGLE)=COS(ANGLE*(pi/180))
  sines(ANGLE)=SIN(ANGLE*(pi/180))
 NEXT ANGLE

 GOSUB setup_shapes

 FOR a=1 TO numstars
  starx(a)=0
  stary(a)=0
  starz(a)=0
 NEXT a

 GOSUB set_target

 xrot=0!xroto=0
 yrot=0!yroto=0
 zrot=0!zroto=0
 offmax=4

 
RETURN

REM buttons
'     ⬆️
'⬅️•➡️
'     ⬇️

  
drawpad:
BUTTON "up" TEXT "⬆️" AT 45+ox,15+oy
BUTTON "press" TEXT "•" AT 45+ox,50+oy
BUTTON "down" TEXT "⬇️" AT 45+ox,85+oy
BUTTON "left" TEXT "⬅️" AT 0+ox,50+oy
BUTTON "right" TEXT "➡️" AT 90+ox,50+oy
BUTTON "in" TEXT "<" AT 0+ox,90+oy
BUTTON "out" TEXT ">" AT 90+ox,90+oy
RETURN

Re: 3d morphing dot demo

Posted: Sun Oct 16, 2016 2:25 pm
by rbytes
Fascinating to watch and play with!

Thanks! :mrgreen:

Re: 3d morphing dot demo

Posted: Tue Apr 14, 2020 4:29 pm
by Wilshusen
For me this is one of the nicest demos I have seen here, together with some labyrinth generators in the first years of this forum.
Thanks, DrChip.
All times are UTC
Page 1 of 1

Powered by phpBB® Forum Software © phpBB Limited