Ball collision detection script runs in Tsunami Cloud IDE

Balls.fsx

/// Processing style vector type
/// See http://processing.org/reference/PVector.html
type PVector(x:float,y:float) =
    new(x:int,y:int) = PVector(float x,float y)
    member val X = x with get,set
    member val Y = y with get,set 
    member vector.Mag() : float =
        sqrt(x * x + y * y)
    member vector.Normalize() : unit =
        let length = vector.Mag()
        vector.X <- vector.X / length
        vector.Y <- vector.Y / length
    member vector.Mult(n:float) : unit = 
        vector.X <- vector.X * n
        vector.Y <- vector.Y * n
    member this.Dot(that:PVector) : float =
        this.X * that.X + this.Y * that.Y
    static member Sub(lhs:PVector,rhs:PVector) : PVector =
        PVector(lhs.X - rhs.X, lhs.Y - rhs.Y)
    static member Mult(vector:PVector, n:float) : PVector =
        PVector(vector.X * n, vector.Y * n)

[<AutoOpen;CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module PVector =
    let componentVector(vector:PVector, direction:PVector) =
        let v = PVector(direction.X, direction.Y)
        v.Normalize()
        v.Mult(vector.Dot(v))
        v
    let resolveFixedCollision(vector:PVector, direction:PVector) =
        let c = PVector.Mult(componentVector(vector, direction), 2.0)
        let v = PVector.Sub(vector, c)
        vector.X <- v.X
        vector.Y <- v.Y

type Ball (width:float, height:float) =

    let random =
        let generator = new System.Random()
        fun (from, until) -> generator.Next(until-from) + from

    let radius = 6.0
    let gravity = 0.1
    let position = PVector(width / 2.0, 20.0)
    let velocity = PVector(random(-2,2), random(1,2))

    (**
     * WALL COLLISION DECTECTION STUFF
     * this function takes 3 parameters, and uses the below other 2 functions
     * 1st position vector
     * 2nd vector starting point
     * 3rd vector slope
     *)
    let circleWallCollision(position:PVector, wallStartPoint:PVector, wall:PVector) =
        let mutable collided = false
        // variables to check if position vector is inside slope bounds
        let d1x = position.X - wallStartPoint.X
        let d1y = position.Y - wallStartPoint.Y
        let d2x = position.X - (wallStartPoint.X + wall.X)
        let d2y = position.Y - (wallStartPoint.Y + wall.Y)
        // check if the position of the ball is inside the boundaries of the wall (slope)
        // if so do the collision stuff
        if sqrt(d1x * d1x + d1y * d1y) < wall.Mag() &&
           sqrt(d2x * d2x + d2y * d2y) < wall.Mag()
        then
            let wallNormal = PVector(-wall.Y, wall.X)
            wallNormal.Normalize()
            // penetration factor
            let a = PVector.Sub(wallStartPoint, position).Dot(wallNormal)
            // check for collision
            if abs(a) < radius then
                resolveFixedCollision(velocity, wallNormal)
                collided <- true
        collided

    // STANDARD STAGE COLLISION DECTECTION
    let checkStageBounds () =
        let mutable collided = false
        if position.X + radius > float width then 
            position.X <- float width - radius
            velocity.X <- velocity.X * -1.0           
            collided <- true
        elif position.X - radius < 0.0 then
            position.X <- radius
            velocity.X <- velocity.X * -1.0
            collided <- true
        if position.Y + radius > float height then
            position.Y <- float height - radius
            velocity.Y <- velocity.Y * -1.0
            collided <- true
        elif position.Y - radius < 0.0 then
            position.Y <- radius
            velocity.Y <- velocity.Y * -1.0
            collided <- true
        collided

    member ball.Radius = radius

    member ball.Update (walls:(float * float * float * float)[]) =
        velocity.Y <- velocity.Y + gravity
        position.X <- position.X + velocity.X
        position.Y <- position.Y + velocity.Y

        let hitWall =
            walls |> Seq.exists (fun (x1,y1,x2,y2) ->
            let slope = PVector(x2 - x1, y2 - y1)
            circleWallCollision(position, PVector(x1,y1), slope);
        )
        let hitBorder = checkStageBounds ()
    
        hitBorder, hitWall, position.X, position.Y

#r "System.Windows.dll"

module Utils =
    open System
    open System.Windows.Controls

    let synchronize f = 
      let ctx = System.Threading.SynchronizationContext.Current 
      f (fun g arg ->
        let nctx = System.Threading.SynchronizationContext.Current 
        if ctx <> null && ctx <> nctx then ctx.Post((fun _ -> g(arg)), null)
        else g(arg) )

    type Microsoft.FSharp.Control.Async with 
      static member AwaitObservable(ev1:IObservable<'a>) =
        synchronize (fun f ->
          Async.FromContinuations((fun (cont,econt,ccont) -> 
            let rec callback = (fun value ->
              remover.Dispose()
              f cont value )
            and remover : IDisposable  = ev1.Subscribe(callback) 
            () )))
  
      static member AwaitObservable(ev1:IObservable<'a>, ev2:IObservable<'b>) = 
        synchronize (fun f ->
          Async.FromContinuations((fun (cont,econt,ccont) -> 
            let rec callback1 = (fun value ->
              remover1.Dispose()
              remover2.Dispose()
              f cont (Choice1Of2(value)) )
            and callback2 = (fun value ->
              remover1.Dispose()
              remover2.Dispose()
              f cont (Choice2Of2(value)) )
            and remover1 : IDisposable  = ev1.Subscribe(callback1) 
            and remover2 : IDisposable  = ev2.Subscribe(callback2) 
            () )))
            
module Rendering =

    open System
    open System.Windows.Controls
    open System.Windows.Media

    let run (control:Control) rate update =
        let rate = TimeSpan.FromSeconds(rate)
        let focus = ref true
        let pause = TimeSpan.FromSeconds(0.5)
        let lastUpdate = ref (DateTime.Now + pause)
        let residual = ref (TimeSpan.Zero)
        let gotFocus _ =
            focus := true
            let pause = TimeSpan.FromSeconds(0.5)
            lastUpdate := DateTime.Now + pause
            residual := TimeSpan.Zero
        let lostFocus _ = 
            focus := false
        let subscriptions = [
            control.GotFocus.Subscribe(gotFocus)
            control.LostFocus.Subscribe(lostFocus)
            CompositionTarget.Rendering.Subscribe (fun _ ->
                let now = DateTime.Now
                if now >= !lastUpdate then
                    residual := !residual + (now - !lastUpdate)
                    if !focus then
                        while !residual > rate do
                            update(); residual := !residual - rate
                    lastUpdate := now
            )]
        { new IDisposable with
            member this.Dispose() =
                subscriptions |> List.iter (fun d -> d.Dispose())
        }

open System
open System.Windows
open System.Windows.Controls
open System.Windows.Media

type Viewport(width, height) as control =
    inherit UserControl()

    let grid = Grid(Background = SolidColorBrush Colors.Gray)
    let canvas = Canvas(Background = SolidColorBrush Colors.Black)
    do  canvas.Width <- width; canvas.Height <- height
    let clip = RectangleGeometry(Rect=Rect(Width=canvas.Width,Height=canvas.Height))
    do  canvas.Clip <- clip
    let transform =
        ScaleTransform(
            ScaleX=1.0,
            ScaleY=1.0,
            CenterX=width/2.0,
            CenterY=height/2.0
        )
    
    do  canvas.RenderTransform <- transform
    do  grid.Children.Add(canvas) |> ignore
    do  control.Content <- grid

    member control.Canvas = canvas

    member control.Border
        with get () = grid.Background
        and set brush = grid.Background <- brush

    member control.AddText(text) =
        let message = 
            TextBlock(
                Text=text,
                HorizontalAlignment = HorizontalAlignment.Center,
                VerticalAlignment = VerticalAlignment.Center,
                Foreground = SolidColorBrush Colors.White,
                FontSize = 16.0)        

        grid.Children.Add(message)
        { new IDisposable with
            member __.Dispose() = grid.Children.Remove(message) |> ignore
        }

    override control.MeasureOverride(size) =
        let mutable scale = 1.0
        while (width * scale) < size.Width && 
              (height * scale) < size.Height do 
              scale <- scale + 0.5
        let scale = scale - 0.5
        let scale = if scale < 1.0 then 1.0 else scale       
        if transform.ScaleX <> scale then
            transform.ScaleX <- scale
            transform.ScaleY <- scale       
        size


#r "Microsoft.Xna.Framework.dll"

module Sound =

    open System
    open Microsoft.Xna.Framework.Audio

    let sampleRate = 44100
    let sample x = x * 32767. |> int16
    let sampleLength duration = duration * float sampleRate |> int

    let pi = Math.PI
    let sineWave freq i = 
        sin (pi * 2. * float i / float sampleRate * freq)
    let fadeOut duration i = 
        let sampleLength = sampleLength duration
        float (sampleLength - i) / float sampleLength
    let tremolo freq depth i = (1.0 - depth) + depth * (sineWave freq i) ** 2.0

    let toBytes (xs:int16[]) =
        let bytes = Array.CreateInstance(typeof<byte>, 2 * xs.Length)   
        Buffer.BlockCopy(xs, 0, bytes, 0, 2 * xs.Length)
        bytes :?> byte[]

    let createSample f duration =
        let sampleLength = duration * float sampleRate |> int
        Array.init sampleLength (f >> min 1.0 >> max -1.0 >> sample)

    let createEffect shape duration =
        let sample = createSample shape duration |> toBytes
        let blank = Array.create sampleRate 0uy // fix sound clicking
        let bytes = Array.append sample blank
        new SoundEffect(bytes, sampleRate, AudioChannels.Mono)

open System
open System.Windows
open System.Windows.Controls
open System.Windows.Input
open System.Windows.Media
open System.Windows.Shapes
open Rendering
open Sound
open Utils

[<AutoOpen>]
module Constants =
    let width, height = 400.0, 600.0

type GameControl () as control =
    inherit Viewport(width, height, IsTabStop=true)   

    let ball = Ball(width, height)

    let ballEllipse = Ellipse(Width=ball.Radius*2.0,Height=ball.Radius*2.0)
    do ballEllipse.Visibility <- Visibility.Collapsed

    do ballEllipse.Fill <- SolidColorBrush Colors.Yellow
    do control.Canvas.Children.Add(ballEllipse)

    let rand = Random()

    let mutable lines : Line list = []
    
    let shape freq duration i = 
        sineWave freq i * fadeOut duration i * tremolo 500. 0.5 i

    let duration = 0.5
    let effects = 
        [
         233.08 // A#
         277.18 // C#
         311.13 // D#
         369.99 // F#
         415.30 // G#
        ]
        |> List.map (fun tone -> shape tone duration)
        |> List.map (fun shape -> createEffect shape duration)
    
    let update () =
        ballEllipse.Visibility <- Visibility.Visible
        let walls = [|for line in lines -> line.X1, line.Y1, line.X2, line.Y2|]
        let hitBorder, hitWall, x, y = ball.Update walls
        Canvas.SetLeft(ballEllipse, x - ball.Radius)
        Canvas.SetTop(ballEllipse, y - ball.Radius)

        control.Border <-
            SolidColorBrush(if hitBorder then Colors.Gray else Colors.Black)

        if hitWall then
            let fx = effects.[rand.Next(effects.Length)].CreateInstance()
            fx.Play()

    let transparentGray = 
        SolidColorBrush(Color.FromArgb(128uy, 164uy, 164uy, 164uy))

    let createLine (x,y) =
        let line = Line(X1=x, Y1=y, X2=x, Y2=y)
        line.Stroke <- transparentGray
        line.StrokeThickness <- 2.0
        line

    let circleRadius = 4.0 
    let mutable circles = []

    let createCircle (x,y) color =
        let diameter = circleRadius * 2.0
        let ellipse = Ellipse(Width=diameter,Height=diameter)
        ellipse.Stroke <- SolidColorBrush color
        Canvas.SetLeft(ellipse, x - circleRadius)
        Canvas.SetTop(ellipse, y - circleRadius)
        control.Canvas.Children.Add(ellipse)
        ellipse
    
    let addCircle line f (x,y) color =
        let ellipse = createCircle (x,y) color
        circles <- (line, ellipse, f) :: circles 
        ellipse

    let findCircle (x,y) =
        circles |> List.tryFind (fun (line, ellipse, (g,s)) ->
            let x',y' = g()
            let d = sqrt ((x-x')*(x-x') + (y-y')*(y-y'))
            d < circleRadius
        )

    let getPosition (args:#MouseEventArgs) =
        let position = args.GetPosition(control.Canvas)
        position.X, position.Y

    let rec waiting() = async {
        let! md = Async.AwaitObservable(control.MouseLeftButtonDown)
        let x,y = getPosition md
        match findCircle(x,y) with
        | Some(line:Line, ellipse, (g,s)) ->
            line.Stroke <- transparentGray
            do! drawing(line, ellipse, s)
        | None ->        
            let line = createLine(x,y)
            lines <- line :: lines
            let get1 () = line.X1, line.Y1
            let set1 (x,y) = line.X1 <- x; line.Y1 <- y
            let _ = addCircle line (get1,set1) (x,y) Colors.Red
            let get2 () = line.X2, line.Y2
            let set2 (x,y) = line.X2 <- x; line.Y2 <- y
            let ellipse = addCircle line (get2,set2) (x,y) Colors.Cyan 
            control.Canvas.Children.Add(line) 
            do! drawing(line, ellipse, set2) 
        }

    and drawing(line:Line, ellipse:Ellipse, f) = async {
        let! evt = Async.AwaitObservable(control.MouseLeftButtonUp, control.MouseMove)
        match evt with
        | Choice1Of2(up) ->
            line.Stroke <- SolidColorBrush(Colors.White)
            do! waiting() 
        | Choice2Of2(move) ->
            let x,y = getPosition move
            f (x,y)            
            Canvas.SetLeft(ellipse, x - 4.0)
            Canvas.SetTop(ellipse, y - 4.0)
            do! drawing(line, ellipse, f) }

    do  waiting() |> Async.StartImmediate

    let start () = async { run control (1.0/60.0) update |> ignore }

    do  control.Loaded.Subscribe(fun _ ->
        if Application.Current.IsRunningOutOfBrowser then start() |> Async.StartImmediate
        else
            let handle = control.AddText "Click To Start"
            async { 
                do! control.MouseLeftButtonDown |> Async.AwaitEvent |> Async.Ignore               
                handle.Dispose()
                do! start ()
            } |> Async.StartImmediate
        ) |> ignore

#r "Tsunami.IDESilverlight.dll"
#r "Telerik.Windows.Controls.dll"
#r "Telerik.Windows.Controls.Docking.dll"
#r "Telerik.Windows.Controls.Navigation.dll"
 
open System
open System.Windows
open System.Windows.Controls
open System.Windows.Media
open System.Windows.Media.Imaging
open Telerik.Windows.Controls
open Telerik.Windows.Controls.Docking
 
let dispatch f = Deployment.Current.Dispatcher.BeginInvoke(fun () -> f())
    
let pane content =
    // Find panes group
    let window = Application.Current.RootVisual :?> Tsunami.IDESilverlight.MainWindow
    let grid = window.Content :?> Grid
    let docking = grid.Children |> Seq.pick (function :? RadDocking as x -> Some x | _ -> None) 
    let container = docking.Items |> Seq.pick (function :? RadSplitContainer as x -> Some x | _ -> None)
    let group = container.Items |> Seq.pick (function :? RadPaneGroup as x -> Some x | _ -> None)
    // Add pane
    let pane = RadPane(Header="Drawing")
    pane.MakeFloatingDockable()
    group.Items.Add(pane)
    // Set content
    pane.Content <- content
    
dispatch <| fun () -> pane (GameControl())