aUCBLogo Demos and Tests / simstring3

be simstring3 [singleshot false][FrameNr 0]
   norefresh
   singlebuffer
   setUpdateGraph false
   maxm=40
   dopt=20
   fac=2 ;1.5 ;0.2
   dopt5=5*dopt
   ffein=100
   maxf=ffein*dopt5
   phE=0.2
   tE=2
   anfE=0.4
   expo=1
   gravV=-0.005*fac
   mov=0.005*fac
   airFriction=0.0002*fac
   size=3
   sizel=list size size
   sizelm=sizel* -1
   f=(FloatArray maxf+1 0)
   j=Int maxf*0.3
   ;for [i 0 j]
   ;[;   f.i=fac*(exp -((i/(dopt*ffein))^expo))*cos 180*i/(2*dopt*ffein)
   ;   f.i=fac*((10*exp -(i/(2*dopt*ffein)))
   ;          *((sqr (i/(2*dopt*ffein)-1)/3)-0.1))
   ;]
   f=rSeqFA 0 -fac maxf+1
   for [i j maxf+1]
   [   f.i=f.j
   ]
   white=RGB 1 1 1
   hideTurtle
;   cs
   pu home
   setpc "white
   pd setx 400 setx -400
   setXY rSeqFA -400 400 maxf+1 f*100
   pu setXY -400+800*dopt*ffein/maxf  300
   pd setXY -400+800*dopt*ffein/maxf -300
;throw "toplevel
   disposalY=0
   onePoint=true
   gravity=false
   air=true
   wavMaking=false
   wav=[]

   m={0 0 0}
   x=Array 3
   o=Array 3
   v=Array 3
   a=Array 3
   xj=Array 3
   hx=Array 3
   for [i 1 3]
   [   x.i=FloatArray maxm
      o.i=FloatArray maxm
      v.i=FloatArray maxm
      a.i=FloatArray maxm
   ]
   x.(1).1= -400   x.(2).1=0      x.(3).1=0
   v.(1).1=0      v.(2).1=0      v.(3).1=0
   for [i 2 maxm]
   [   x.(1).i=x.(1).1+(i-1)*dopt
      x.(2).i=0
      x.(3).i=0
      v.(1).i=0
      v.(2).i=0
      v.(3).i=0
   ]

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

   running=true
   while [running]
   [   for [k 1 10]
      [   moveThem
         updateGraph
         if singleshot [stop]
         if wavMaking
         [   wav=fput 0+x.2 wav
            wavlength=wavlength+1
         ]
         if MouseButtons==1 [MousePulling]
         if Key?
         [   ch=upperCase readChar
            case ch
            [   [[char wxk_escape] running=false]
               [[char wxk_return] onePoint=not onePoint]
               ["- cooling]
               ["+ heating]
               ["G gravity=not gravity (print [Gravity] gravity)]
               ["A air=not air (print [Air] air)]
               ["W ifelse wavMaking
                  [   StaticTextDestroy wavInfo
                     saveWav
                  ][   wavlength=0
                     wavInfo=StaticText [] 0
                     StaticTextSetColor wavInfo 0
                  ]
                  wavMaking=not wavMaking
               ]
               ["i m.3=m.3+10 print m.3];in
               ["o m.3=m.3-10 print m.3];out
               [else clean]
            ]
         ]
         GC
      ]
      if wavMaking
      [   StaticTextSetLabel wavInfo wavLength
      ]
   ]

   be moveThem
      for [i 1 3]
      [   a.i=rSeqFA 0 0 maxm
         xj.i=rotate x.i 1
      ]
      dx=x-xj
      d=sqrt (sqr dx.1)+(sqr dx.2)+(sqr dx.3)
      d=f.saturateAbove maxf IntArray trunc d*ffein
      for [i 1 3][hx.i=dx.i*d]

      a=a+hx
      for [i 1 3][a.i=a.i-rotate hx.i -1]
      if air
      [   vair=(sqrt (sqr v.1)+(sqr v.2)+(sqr v.3))*airFriction
         for [i 1 3][a.i=a.i-v.i*vair]
      ]
      v=v+a
      if gravity
      [   v.2=v.2+gravV
      ]
      v.(1).1=0   v.1.maxm=0
      v.(2).1=0   v.2.maxm=0
      v.(3).1=0   v.3.maxm=0
      x=x+v
      d.1=0   d.maxm=0
      for [i 1 maxm]
      [   if onePoint
         [   setFC 0
            pu setXY o.(1).i o.(2).i
            pd fillRect sizelm sizel
         ]
         c=Int 15+1500*abs d.i
         if c > 255 [c=255]
         setFC pal.c
         pu setXY x.(1).i x.(2).i
         pd fillRect sizelm sizel
      ]
      o=x
   end

   be cooling
      v=v/tE
   end

   be heating
      v=v*tE
   end

   be MousePulling
      local [i d]
      m.1=MouseX
      m.2=MouseY
      i=findNearest m

      if onePoint
      [   setFC 0
         pu setXY x.(1).i x.(2).i
         pd fillRect sizelm sizel
      ]
      for [k 1 3][v.k.i=v.k.i/tE+(m.k-x.k.i)*mov]
      ConsoleSetFocus
   end

   be findNearest f
      local [i j dmin d]
      dmin=intmax
      for [i 1 maxm]
      [   d=trunc sqrt
             (sqr f.1-x.(1).i)
            +(sqr f.2-x.(2).i)
            +(sqr f.3-x.(3).i)
         if d < dmin
         [   dmin=d
            j=i
         ]
      ]
      output j
   end

   be 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.5
      ][   volume=Int16Max/(min wav)*0.5
      ]
      foreach wav
      [   typebin int16 ?*volume
      ]
      setWriter []
      close "tmp.wav
   end
end