aUCBLogo Demos and Tests / simstring2

to simstring2
   init
   running=true
   while [running]
   [   for [k 1 100]
      [   moveThem
         if wavMaking
         [   wav=fput 0+y wav
            wavlength=wavlength+1
         ]
         case MouseButtons
         [   [1 mousePulling]
            [2 ]
         ]
      ]
      if wavMaking
      [   StaticTextSetLabel wavInfo wavLength
      ]
      if Key?
      [   ch=readChar
         case ch
         [   [[char WXK_ESCAPE] running=false]
            [[char WXK_RETURN] onePoint=not onePoint]
            ["- cooling]
            ["+ heating]
            ["G gravity=not gravity]
            ["A air=not air]
            ["W ifelse wavMaking
               [   StaticTextDestroy wavInfo
                  saveWav
               ][   wavlength=0
                  wavInfo=StaticText [] 0
                  StaticTextSetColor wavInfo 0
               ]
               wavMaking=not wavMaking
            ]
            ["i mz=mz+10 print mz];in
            ["o mz=mz-10 print mz];out
            [else clean]
         ]
      ]
      GC
   ]
end

to init
   norefresh
   singlebuffer
   maxm=40
   maxb=1
   dopt=15
   dopt5=5*dopt
   ffein=100
   maxf=ffein*dopt5
   phE=0.2
   tE=1.1
   anfE=0.4
   expo=1
   fac=1.5 ;0.2
   gravV=-0.005*fac
   mov=0.1*fac
   airFriction=0.0002*fac
   size=2
   sizel=list size size
   sizelm=sizel*-1
   f=(FloatArray maxf+1 0)
   for [i 0 maxf]
   [;   f.i=fac*(exp -((i/(dopt*ffein))^expo))*cos 180*i/(2*dopt*ffein)
      f.i=fac*((5*exp -(i/(2*dopt*ffein)))
             *((sqr (i/(4*dopt*ffein)-0.5))-0.1))
   ]
   white=RGB 1 1 1
   hideTurtle
   cs setpc "white
   setx 400 setx -400
   setXY rSeqFA -400 400 maxf+1 f*100
;throw "toplevel
   disposalY=0
   mx=0
   my=0
   mz=0
   onePoint=true
   gravity=false
   air=true
   wavMaking=false
   wav=[]

   x=FloatArray maxm
   y=FloatArray maxm
   z=FloatArray maxm
   ox=FloatArray maxm
   oy=FloatArray maxm
   oz=FloatArray maxm
   vx=FloatArray maxm
   vy=FloatArray maxm
   vz=FloatArray maxm
   ax=FloatArray maxm
   ay=FloatArray maxm
   az=FloatArray maxm

   x.1= -300   y.1=0      z.1=0
   vx.1=0      vy.1=0      vz.1=0
   for [i 2 maxm]
   [   x.i=x.1+(i-1)*dopt
      y.i=0
      z.i=0
      vx.i=0
      vy.i=0
      vz.i=0
   ]

   (reRandom 0)
   (print [[RETURN]splines [+]heat [-]cool [G]ravity [A]ir
      [other key]=clean Mouse: L=pull R=del])
   pal=loadPalette "teile.pal
   setScreenColor pal.1
   WindowMode
end

to moveThem
   ax=rSeqFA 0 0 maxm
   ay=rSeqFA 0 0 maxm
   az=rSeqFA 0 0 maxm
   xj=rotate x 1
   yj=rotate y 1
   zj=rotate z 1
   dx=x-xj
   dy=y-yj
   dz=z-zj
   d=sqrt (sqr dx)+(sqr dy)+(sqr dz)
   d=f.saturateAbove maxf IntArray trunc d*ffein
   hx=dx*d
   hy=dy*d
   hz=dz*d

   ax=ax+hx
   ay=ay+hy
   az=az+hz
   ax=ax-rotate hx -1
   ay=ay-rotate hy -1
   az=az-rotate hz -1

   if air
   [   vair=(sqrt (sqr vx)+(sqr vy)+(sqr vz))*airFriction
      ax=ax-vx*vair
      ay=ay-vy*vair
      az=az-vz*vair
   ]
   vx=vx+ax
   vy=vy+ay
   vz=vz+az
   if gravity
   [   vy=vy+gravV
   ]
   vx.1=0   vx.maxm=0
   vy.1=0   vy.maxm=0
   vz.1=0   vz.maxm=0
   x=x+vx
   y=y+vy
   z=z+vz
   for [i 1 maxm]
   [   if onePoint
      [   setFC 0  pu setXY ox.i oy.i pd fillRect sizelm sizel
      ]
      c=Int 1+700*abs d.i
      if c > 255 [c=255]
      setFC pal.c
      pu setXY x.i y.i pd fillRect sizelm sizel
   ]
   ox=x
   oy=y
   oz=z
end

to cooling
   for [i 1 maxm]
   [   vx.i=vx.i/tE
      vy.i=vy.i/tE
      vz.i=vz.i/tE
   ]
end

to heating
   for [i 1 maxm]
   [   vx.i=vx.i*tE
      vy.i=vy.i*tE
      vz.i=vz.i*tE
   ]
end

to MousePulling
   mx=MouseX
   my=MouseY
   i=findNearest mx my mz

   setFC 0  pu setXY x.i y.i pd fillCircle size
   vx.i=0
   vy.i=0
   vz.i=0
   d=((sqr mx-x.i)+(sqr my-y.i)+(sqr mz-z.i))^0.3
   x.i=x.i+mov*(mx-x.i)/d
   y.i=y.i+mov*(my-y.i)/d
   z.i=z.i+mov*(mz-z.i)/d
   ConsoleSetFocus
end

to findNearest fx fy fz
   local [i j dmin d]
   dmin=IntMax
   for [i 1 maxm]
   [   d=trunc sqrt (sqr fx-x.i)+(sqr fy-y.i)+(sqr fz-z.i)
      if d < dmin
      [   dmin=d
         j=i
      ]
   ]
   output j
end

to saveWav
   local [size]
   rate=44100
   size=count wav

   openWriteBin "tmp.wav
   setWriter "tmp.wav
   type [RIFF]
   typebin 4+8+8+16+size*2
   type [WAVE]
   type [fmt\ ]
   typebin 16
   typebin int16 1
   typebin int16 1
   typebin rate
   typebin rate*2
   typebin int16 2
   typebin int16 16
   type [data]
   typebin size*2

   wav=reverse wav
   ifelse (max wav) > (min wav)
   [   volume=Int16Max/(max wav)*0.9
   ][   volume=Int16Max/(min wav)*0.9
   ]
   foreach wav
   [   typebin int16 ?*volume
   ]
   setWriter []
   close "tmp.wav
end