Ballgame in F# using Silverlight and WPF

Today I am creating a game application named BallGame in F# using WPF, Silverlight. Steps are given below.

Step 1: Firstly Open a new project in F# using Visual Studio 2010. Select F# WPF application template and give a name to it like the below image.

New Project Dialog Box

Step 2: Now add the below define references, a new F# silverlightapp project and some beep tune files to the project by right clicking on project in solution explorer.

Accessibility
PresentationCore
PresentationFramework
System
System.Xaml
System.Xml
System.Core
System.Numerics
System.Data
System.Drawing
WindowsBase
UIAutomationProvider
UIAutomationTypes

Step 3: When you have added all these references, new project and all beep tune files your Solution Explorer will look like the below image.

Solution Explorer

Step 4: Now click on the Module1.fs file in the Solution Explorer and write the below code in the Module1.fs window, your window will look like below.

BallgameCode part1

Ballgame Code part2

Ballgame code part3

Ballgame code part 4

Ballgame code part5

Ballgame code part6

Ballgame Code part7

namespace Ballgame

open System.Windows
open System.Windows.Shapes
open System.Windows.Controls
open System.Windows.Controls.Primitives
open System.Windows.Media

module BGameWpf =
module Cnvs =
let SetTopLeft(element, top, left) =
Canvas.SetTop(element, top)
Canvas.SetLeft(element, left)
type System.Windows.Controls.Canvas with
member this.AddAt(top, left, element) =
Cnvs.SetTopLeft(element,top,left)
this.Children.Add(element) |> ignore
let YELLOW = new SolidColorBrush(Colors.Yellow)
let WHITE = new SolidColorBrush(Colors.White)
let RED = new SolidColorBrush(Colors.Red)
open BGameWpf

module GlobConstConfig =
let a = 0.0003
// pixel size of a ball/brick
let TotSIZE = 7.0
// initial grid size of blocks
let TOTWDT = 80
let TOTHGT = 20
// paddle size
let RESTHEGT = 11.0
let RESTWDT = 9.0 * TotSIZE
let RESTCHT = false
open GlobConstConfig

module GlobCompConst =
let HLFSIZE = TotSIZE / 2.0
// pixel location of bottom of bricks
let BTBALL = float TOTHGT * TotSIZE
// canvas size
let CNWDT=TotSIZE * float TOTWDT
let CNHGT=TotSIZE * 90.0
// pixel location of top of paddle
let TOPPAD = CNHGT-70.0
let HLFRESTWDT = RESTWDT / 2.0
open GlobCompConst

module GLBLS =
let ldXaml<'T when 'T :> FrameworkElement>(xamlPath) =
use stream = System.Reflection.Assembly.GetExecutingAssembly().GetManifestResourceStream(xamlPath) // if BuildAction=EmbeddedResource
#if SILVERLIGHT
let stream = (new System.IO.StreamReader(stream)).ReadToEnd()
#endif
let nxaml = System.Windows.Markup.XamlReader.Load(stream)
let uObj = nxaml :?> 'T
uObj

let (?) (fe:FrameworkElement) firstName : 'T =
fe.FindName(firstName) :?> 'T

let nwPnl : StackPanel = ldXaml("MainWindow.xaml")
let cnvs : Canvas = nwPnl?canvas
let pup : Popup = nwPnl?popup
let pupCanvas : Canvas = nwPnl?popupCanvas
let pupTp : TextBox = nwPnl?popupTop
let pupMdl : TextBox = nwPnl?popupMiddle
let pupBtm : TextBox = nwPnl?popupBottom
let RANG = new System.Random()
// main data objects
let mutable rmnng = TOTWDT * TOTHGT
let mutable actv= 1
let mutable wntPdlBp = false
let mutable wntBlkBp = false
let mutable fstTme = true
// main UI objects
let txtblc = new TextBlock(Height=25.0, Width=CNWDT, Text="", FontSize=20.0)
let dbug = new TextBlock(Height=25.0, Width=CNWDT, Text="", FontSize=10.0)
let pdl = new Rectangle(Width=RESTWDT, Height=RESTHEGT, Fill=YELLOW)
/// as I varies from 0-max-1, this makes a pretty color spectrum
let mkClr(I,max) =
if I < 1*max/4 then
let px = (I-0*max/4)*256*4/max
new SolidColorBrush(Color.FromArgb(0xD0uy,0xD0uy,byte(px),4uy))
elif I < 2*max/4 then
let px = (I-1*max/4)*256*4/max
new SolidColorBrush(Color.FromArgb(0xD0uy,0xD0uy,byte(px),4uy))
elif I < 3*max/4 then
let px = (I-2*max/4)*256*4/max
new SolidColorBrush(Color.FromArgb(0xD0uy,0xD0uy,byte(px),4uy))
else
let px = (I-3*max/4)*256*4/max
new SolidColorBrush(Color.FromArgb(0xD0uy,0xD0uy,byte(px),4uy))

let NMBP = 20
#if SILVERLIGHT
let mkMda(file) = new MediaElement(Source = new System.Uri(file, System.UriKind.Relative), AutoPlay = false)
#else
let mkMda(file) = new MediaElement(Source = new System.Uri(file, System.UriKind.Relative), LoadedBehavior = MediaState.Manual)
#endif

let attachMedia(file) =
let sund = mkMda(file)
sund.MediaFailed.Add (fun ea -> dbug.Text <- ea.ErrorException.ToString())
cnvs.Children.Add(sund) |> ignore
sund

let bps = Array.init NMBP (fun _ -> attachMedia("BEPPUR.wma"))
let mutable curBeep = 0
let blkBps = Array.init NMBP (fun _ -> attachMedia("BEPDUB.wma"))
let windSund = attachMedia("happykids.wma")
let lseSund = attachMedia("boo.wma")
let plyOnc(sound : MediaElement) =
async { sound.Play()
let! _ = Async.AwaitEvent sound.MediaEnded
sound.Stop() } |> Async.StartImmediate
// useful functions
let Asrt(b) =
assert(b)
//if not b then raise <| new System.Exception("assert failed")

// screen coordinates, a ball hit a block (filling space [0-SIZE,0-SIZE]) at point
// (x,y) with velocity (dx,dy) - did it hit the side of the brick (as opposed to top/bottom)?
let htSde(x,y,dx,dy) =
let blSlpe = -dy/dx
if dy>0.0 then
if dx<0.0 then
// it's going 'down-left'
let s = y/(TotSIZE-x)
blSlpe < s
else
// it's going 'down-right'
let s = -y/x
blSlpe > s
else
if dx>0.0 then
// it's going 'up-right'
let s = (TotSIZE-y)/x
blSlpe < s
else
// it's going 'up-left'
let s = -(TotSIZE-y)/(TotSIZE-x)
blSlpe > s
let _ok =
Asrt(htSde(HLFSIZE,HLFSIZE,10.0,1.0)) // -
Asrt(htSde(HLFSIZE,HLFSIZE,10.0,-1.0)) // -
Asrt(not<|htSde(HLFSIZE,HLFSIZE,1.0,-10.0)) // |
Asrt(not<|htSde(HLFSIZE,HLFSIZE,-1.0,-10.0)) // |
Asrt(htSde(HLFSIZE,HLFSIZE,-10.0,-1.0)) // -
Asrt(htSde(HLFSIZE,HLFSIZE,-10.0,1.0)) // -
Asrt(not<|htSde(HLFSIZE,HLFSIZE,-1.0,10.0)) // |
Asrt(not<|htSde(HLFSIZE,HLFSIZE,1.0,10.0)) // |

let ensureNonZero x = if x=0.0 then a else x
open GLBLS

[<RequireQualifiedAccess>]
type BlkStt =
| StartPosition // in block rows at top
| Actv // a ball, moving around
| Rmvd // fell off bottom

type Blk(shape : Ellipse) =
let mutable state = BlkStt.InitialPosition
// next 3 fields only matter when state=Active
let mutable xSpeed = 0.0
let mutable ySpeed = 0.0
let mutable tail : Line = null
do Asrt(cnvs.Children.Contains(shape))
member this.State = state
member this.Shape = shape
member this.Reflect() =
ySpeed <- -abs(ySpeed)
member this.Remove() =
Asrt(state = BlkStt.Active)
cnvs.Children.Remove(shape) |> ignore
cnvs.Children.Remove(tail) |> ignore
state <- BlkStt.Removed
member this.BreakAway() =
Asrt(state = BlkStt.InitialPosition)
xSpeed <- ensureNonZero(TotSIZE * (RANG.NextDouble() - 0.5))
ySpeed <- TotSIZE * (RANG.NextDouble() + 2.0)/3.1 // trying to ensure ySpeed < SIZE, so ball never goes completely through a row undetected in a single 'step'
Canvas.SetTop(shape, Canvas.GetTop(shape)+TotSIZE*1.5)
tail <- new Line(X1=Canvas.GetLeft(shape), X2=Canvas.GetLeft(shape),
Y1=Canvas.GetTop(shape), Y2=Canvas.GetTop(shape),
StrokeThickness=TotSIZE/3.0, Stroke=WHITE)
cnvs.Children.Add(tail) |> ignore
state <- BlkStt.Active
member this.MoveOneStep() =
Asrt(state = BlkStt.Active)
let orgCntrdX = Canvas.GetLeft(shape) + HLFSIZE
let orgCntrdY = Canvas.GetTop(shape) + HLFSIZE
// compute new X
let nwX = xSpeed + Canvas.GetLeft(shape)
let flpX(r) = xSpeed <- -xSpeed; r
let nwX = if nwX < 0.0 then flpX 0.0 else nwX
let nwX = if nwX > CNWDT-a then flpX(CNWDT-a) else nwX
// compute new Y
let nwY = ySpeed + Canvas.GetTop(shape)
let flpY(r) = ySpeed <- -ySpeed; r
let nwY = if nwY < 0.0 then flpY 0.0 else nwY
// update position
Cnvs.SetTopLeft(shape, nwY, nwX)
// update trailer line
let nwCntrdX = Canvas.GetLeft(shape) + HLFSIZE
let nwCntrdY = Canvas.GetTop(shape) + HLFSIZE
tail.X2 <- nwCntrdX
tail.Y2 <- nwCntrdY
tail.X1 <- 4.0 * (orgCntrdX - nwCntrdX) + nwCntrdX
tail.Y1 <- 4.0 * (orgCntrdY - nwCntrdY) + nwCntrdY
member this.HitPaddle(dx) =
Asrt(state = BlkStt.Active)
ySpeed <- -abs(ySpeed)
xSpeed <- ensureNonZero(xSpeed + dx)
member this.ReboundOffBrick(dLeft, dTop) =
let sde = htSde(dLeft,dTop,xSpeed,ySpeed)
if sde then
xSpeed <- -xSpeed
else
ySpeed <- -ySpeed

type NewApp() as this =
#if SILVERLIGHT
inherit Application()
#else
inherit Window()
#endif
let concon = new ContentControl()
let blks = Array2D.init TOTHGT TOTWDT (fun y x ->
let e = new Ellipse(Width=TotSIZE, Height=TotSIZE, Fill=mkClr(x,TOTWDT))
cnvs.AddAt(TotSIZE * float y, TotSIZE * float x, e)
new Blk(e))

do
cnvs.Width <- CNWDT; cnvs.Height <- CNHGT
cnvs.AddAt(TOPPAD, CNWDT / 2.0, pdl)
cnvs.AddAt(TOPPAD+RESTHEGT+5.0, 10.0, txtblc)
cnvs.AddAt(TOPPAD+RESTHEGT+30.0, 10.0, dbug)

pupCanvas.Background <- new SolidColorBrush(Color.FromArgb(0xFFuy,0uy,0uy,0xFFuy), Opacity=0.6)
pup.HorizontalAlignment <- HorizontalAlignment.Left
pup.VerticalAlignment <- VerticalAlignment.Top
#if SILVERLIGHT
// Silverlight popups are relative to the whole control
#else
// WPF popups have more control
pup.Placement <- PlacementMode.Relative
pup.PlacementTarget <- nwPnl
pup.HorizontalOffset <- 0.0
pup.VerticalOffset <- 0.0
#endif

blks.[TOTHGT-1,TOTWDT/2].BreakAway()
rmnng <- rmnng - 1
// txtblc.Text <- sprintf "%d Wall remain, %d Wall active" rmnng actv

#if SILVERLIGHT
this.UnhandledException.Add(fun ea -> dbug.Text <- ea.ExceptionObject.ToString())
this.Startup.Add(fun _ ->
#else
this.Loaded.Add(fun _ ->
#endif
async {
do! Async.Sleep(50) // a hack, need to wait until ActualHeight is populated
pupCanvas.Height <- nwPnl.ActualHeight
pupCanvas.Width <- nwPnl.ActualWidth
pup.IsOpen <- true
pupTp.Text <- "Quick Play Funny BallGame!"
pupTp.HorizontalAlignment <- HorizontalAlignment.Center // TODO cannot seem to auto-align these; design-time issue? recompute layout?
pupMdl.Text <- "Instructions: If you want to control the box you can move it through it Mouse\nSave Balls from falling down\nBreak walls on Upper side to get
more\nEnjoy the Game!"
pupBtm.Text <- "Press 's' to start"
} |> Async.StartImmediate
async {
do! Async.Sleep(100)
while rmnng > 0 && actv > 0 do
do! Async.Sleep(20)
do // this 'do' line is important to memory performance - code below is all sync, so need to execute outside 'async' to avoid Async allocating
if pup.IsOpen then () else
wntPdlBp <- false
wntPdlBp <- false
curBeep <- (curBeep + 1) % NMBP
let leftPad = Canvas.GetLeft(pdl)
for y in 0..TOTHGT-1 do
for x in 0..TOTWDT-1 do
let ball = blks.[y,x]
if ball.State = BlkStt.Active then
ball.MoveOneStep()
let top = Canvas.GetTop(ball.Shape)
let left = Canvas.GetLeft(ball.Shape)
if top >= TOPPAD && top < TOPPAD+RESTHEGT && left >= leftPad && left < leftPad+RESTWDT then
// hit paddle
ball.HitPaddle(dx=(left - leftPad - HLFRESTWDT)/HLFRESTWDT)
wntPdlBp <- true
elif top < BTBALL then
// see if hit a stationary brick
let brick = blks.[int(top / TotSIZE),int(left / TotSIZE)]
if brick.State = BlkStt.InitialPosition then
let t = Canvas.GetTop(brick.Shape)
let l = Canvas.GetLeft(brick.Shape)
let intersect = left >= l && left < l+TotSIZE && top >= t && top < t+TotSIZE
if intersect then
rmnng <- rmnng - 1
actv <- actv + 1
//txtblc.Text <- sprintf "%d Wall remain, %d Wall active" rmnng actv
ball.ReboundOffBrick(dLeft=l-left, dTop=t-top)
brick.BreakAway()
wntBlkBp <- true
elif top > CNHGT then
// fell off bottom
if RESTCHT then
ball.Reflect()
else
ball.Remove()
actv <- actv - 1
// txtblc.Text <- sprintf "%d Wall remain, %d Wall active" rmnng actv
if wntPdlBp then
plyOnc(bps.[curBeep])
if wntBlkBp then
plyOnc(blkBps.[curBeep])
if rmnng > 0 then
//txtblc.Text <- sprintf "left %d Wall" rmnng
plyOnc(lseSund)
else
txtblc.Text <- "Hurrah You Won!!!"
plyOnc(windSund)
} |> Async.StartImmediate
)

// to be able to get focus
concon.IsTabStop <- true
concon.IsEnabled <- true
concon.KeyDown.Add(fun keyEA ->
if keyEA.Key = Input.Key.S then
pupCanvas.Height <- nwPnl.ActualHeight\
pupCanvas.Width <- nwPnl.ActualWidth
pup.IsOpen <- not pup.IsOpen
pupTp.Text <- "STOP"
pupMdl.Text <- "F# - 'fun' is our keyword!"
pupBtm.Text <- "Press 's' to unstop and continue"
)
#if SILVERLIGHT

#else
concon.Focus() |> ignore
#endif
nwPnl.MouseMove
|> Observable.add (fun ea ->
let x = ea.GetPosition(cnvs).X
if x < HLFRESTWDT then
Canvas.SetLeft(pdl, 0.0)
elif x <= CNWDT - HLFRESTWDT then
Canvas.SetLeft(pdl, x - HLFRESTWDT)
else
Canvas.SetLeft(pdl, CNWDT - RESTWDT)
)
concon.Content <- nwPnl
#if SILVERLIGHT

#else
this.Content <- concon
this.SizeToContent <- SizeToContent.WidthAndHeight
#endif

#if SILVERLIGHT
#else
module Main =
[<System.STAThread()>]
do
let app = new Application()
app.Run(new NewApp()) |> ignore
#endif