18 people like it.

Tetris

Playable Tetris mini-game. Use arrow keys to move left and right and up to rotate, down to drop. Try it out in the browser on TryFSharp.org

  1: 
  2: 
  3: 
  4: 
  5: 
  6: 
  7: 
  8: 
  9: 
 10: 
 11: 
 12: 
 13: 
 14: 
 15: 
 16: 
 17: 
 18: 
 19: 
 20: 
 21: 
 22: 
 23: 
 24: 
 25: 
 26: 
 27: 
 28: 
 29: 
 30: 
 31: 
 32: 
 33: 
 34: 
 35: 
 36: 
 37: 
 38: 
 39: 
 40: 
 41: 
 42: 
 43: 
 44: 
 45: 
 46: 
 47: 
 48: 
 49: 
 50: 
 51: 
 52: 
 53: 
 54: 
 55: 
 56: 
 57: 
 58: 
 59: 
 60: 
 61: 
 62: 
 63: 
 64: 
 65: 
 66: 
 67: 
 68: 
 69: 
 70: 
 71: 
 72: 
 73: 
 74: 
 75: 
 76: 
 77: 
 78: 
 79: 
 80: 
 81: 
 82: 
 83: 
 84: 
 85: 
 86: 
 87: 
 88: 
 89: 
 90: 
 91: 
 92: 
 93: 
 94: 
 95: 
 96: 
 97: 
 98: 
 99: 
100: 
101: 
102: 
103: 
104: 
105: 
106: 
107: 
108: 
109: 
110: 
111: 
112: 
113: 
114: 
115: 
116: 
117: 
118: 
119: 
120: 
121: 
122: 
123: 
124: 
125: 
126: 
127: 
128: 
129: 
130: 
131: 
132: 
133: 
134: 
135: 
136: 
137: 
138: 
139: 
140: 
141: 
142: 
143: 
144: 
145: 
146: 
147: 
148: 
149: 
150: 
151: 
152: 
153: 
154: 
155: 
156: 
157: 
158: 
159: 
160: 
161: 
162: 
163: 
164: 
165: 
166: 
167: 
168: 
169: 
170: 
171: 
172: 
173: 
174: 
175: 
176: 
177: 
178: 
179: 
180: 
181: 
182: 
183: 
184: 
185: 
186: 
187: 
188: 
189: 
190: 
191: 
192: 
193: 
194: 
195: 
196: 
197: 
198: 
199: 
200: 
201: 
202: 
203: 
204: 
205: 
206: 
207: 
208: 
209: 
210: 
211: 
212: 
213: 
214: 
215: 
216: 

Skip module definition on TryFSharp.org

open System
open System.Windows
open System.Windows.Controls
open System.Windows.Input
open System.Windows.Media
open System.Windows.Shapes

Keyboard input

let tetrads =
    [
        [0,0;0,1;0,2;0,3],Colors.Red, Colors.Yellow
        [0,0;1,0;0,1;1,1],Colors.Blue, Colors.Cyan
        [0,0;1,0;2,0;1,1],Colors.Purple, Colors.Magenta
        [0,0;1,0;2,0;0,1],Colors.Yellow, Colors.Orange
        [0,0;1,0;2,0;2,1],Colors.White, Colors.LightGray
        [0,0;1,0;1,1;2,1],Colors.Green, Colors.Gray
        [0,1;1,1;1,0;2,0],Colors.Brown, Colors.DarkGray
    ]

type Block = { X:int; Y:int; Rectangle:Rectangle }
type Tetrad = { Blocks:Block list; Canvas:Canvas }

let setPosition (block:#UIElement) (x,y) =    
    block.SetValue(Canvas.LeftProperty, x)
    block.SetValue(Canvas.TopProperty, y)

let blockSize = 16.0
let toPosition (x,y) = float x * blockSize, float y * blockSize

let positionBlock block =
    (block.X, block.Y) |> toPosition |> setPosition block.Rectangle

let positionBlocks blocks = 
    blocks |> List.iter positionBlock

let positionTetrad tetrad (x,y) =
    (x,y) |> toPosition |> setPosition tetrad.Canvas
    
let createTetrad (coordinates,stroke,fill) =    
    let createRectangle () =
        Rectangle(
            Width=blockSize,Height=blockSize,
            Fill=SolidColorBrush fill,
            Stroke=SolidColorBrush stroke,
            StrokeThickness=2.0)    
    let createBlocks coordinates =
        coordinates |> List.map (fun (x,y) ->
            let rectangle = createRectangle ()        
            { X=x; Y=y; Rectangle=rectangle }
        )
    let composeBlocks blocks =
        let canvas = new Canvas()
        blocks |> List.iter (fun block ->            
            canvas.Children.Add block.Rectangle
        )
        canvas
    let blocks = createBlocks coordinates
    positionBlocks blocks
    let canvas = composeBlocks blocks
    { Blocks=blocks; Canvas=canvas }

let wellWidth, wellHeight = 10, 20

type Well() =
    let canvas = Canvas() 
    let matrix = Array2D.create wellWidth wellHeight None
    let addBlock (x,y) block =
        matrix.[x,y] <- Some block
        canvas.Children.Add block
    let clear () =
        matrix |> Array2D.iteri (fun x y block ->
            block |> Option.iter (fun block ->
                canvas.Children.Remove block |> ignore
                matrix.[x,y] <- None
            )
        )        
    let isBlocked (x,y) =
        if x < 0 || x >= wellWidth then true
        elif y < 0 || y >= wellHeight then true
        else
            matrix.[x,y] |> Option.exists (fun x -> true)
    let checkLines () =
        let lineBlockCounts =
            [0..wellHeight-1] |> List.map (fun y ->
                [0..wellWidth-1] 
                |> List.map (fun x -> matrix.[x,y])
                |> List.map Option.count 
                |> List.reduce (+), y
            )
        let clearLine y =
            for x = 0 to wellWidth-1 do
                matrix.[x,y] |> Option.iter (fun block -> 
                    canvas.Children.Remove block |> ignore)
                matrix.[x,y] <- None
        let fallDownTo y =
            for i = y-1 downto 1 do
                for x = 0 to wellWidth-1 do
                    let block = matrix.[x,i]                        
                    block |> Option.iter (fun block ->                         
                        setPosition block (toPosition (x,i+1))
                        matrix.[x,i+1] <- Some block
                        matrix.[x,i] <- None
                    )
        lineBlockCounts |> List.iter (fun (count,y) -> 
            if count = wellWidth then
                clearLine y
                fallDownTo y             
        )
    member well.IsBlocked = isBlocked
    member well.AddBlock (x,y) (block:UIElement) = addBlock (x,y) block         
    member well.CheckLines () = checkLines ()
    member well.Clear () = clear ()
    member well.Control = canvas

type GameControl() as this =
    inherit UserControl(
            Width = float wellWidth*blockSize, 
            Height = float wellHeight*blockSize,
            IsTabStop = true)

    let keys = KeyState(this)    
    let well = Well()           
    let canvas = Canvas(Background=SolidColorBrush Colors.Black)
    do  canvas.Children.Add(well.Control)
    let layout = Grid()
    do  layout.Children.Add canvas
    do  this.Content <- layout

    let isTetradBlocked (tetrad) (x,y) =
        tetrad.Blocks |> List.exists (fun block ->            
            (block.X + x, block.Y + y) |> well.IsBlocked
        )

    let rotateTetrad tetrad =
        let blocks = 
            tetrad.Blocks |> List.map (fun block ->
                {block with X = block.Y; Y = -block.X}
            )                        
        { tetrad with Blocks=blocks }

    let controlTetrad tetrad (x,y) =
        let dx = 
            keys.ReadKeyPresses Key.Right - keys.ReadKeyPresses Key.Left
            |> sign                                              
        let rotate = keys.ReadKeyPressed Key.Up                              
        let newTetrad = if rotate then rotateTetrad(!tetrad) else !tetrad            
        if not (isTetradBlocked newTetrad (!x+dx,!y+1)) then
            positionBlocks newTetrad.Blocks
            tetrad := newTetrad
            x := !x + dx

    let dockTetrad (tetrad) (x,y) =
        tetrad.Blocks |> List.iter (fun block ->
            tetrad.Canvas.Children.Remove block.Rectangle |> ignore
            let x',y' = block.X + x, block.Y + y
            setPosition block.Rectangle (toPosition (x', y'))                                    
            block.Rectangle |> well.AddBlock (x',y') 
        )

    let playTetrad tetrad (x,y) = async {
        positionTetrad !tetrad (!x,!y)                                                 
        canvas.Children.Add (!tetrad).Canvas
        let speed = ref 300       
        while not (isTetradBlocked !tetrad (!x,!y)) do            
            do! Async.Sleep !speed
            if keys.ReadKeyPressed Key.Down then speed := 30                
            controlTetrad tetrad (x,y)
            incr y
            if isTetradBlocked !tetrad (!x,!y+1) then
                dockTetrad (!tetrad) (!x,!y)
                canvas.Children.Remove (!tetrad).Canvas |> ignore
            positionTetrad !tetrad (!x,!y)                   
        }

    let rand = Random()  
    let rec inGameLoop () = async {  
        let index = rand.Next tetrads.Length 
        let tetrad = ref (createTetrad tetrads.[index])
        let x, y = ref (wellWidth/2 - 2), ref 0      
        if not (isTetradBlocked !tetrad (!x,!y+1)) then
            do! playTetrad tetrad (x,y) 
            well.CheckLines()
            return! inGameLoop ()   
        }

    let message s =
        TextBlock(
            Text=s,
            HorizontalAlignment = HorizontalAlignment.Center,
            VerticalAlignment = VerticalAlignment.Center,
            Foreground = SolidColorBrush Colors.White)        

    let prompt text action = async {
        let start = message text
        layout.Children.Add start
        do! action()
        layout.Children.Remove start |> ignore
        }
        
    let awaitClick () = this.MouseLeftButtonDown |> Async.AwaitEvent |> Async.Ignore
    let pause () =  Async.Sleep 5000

    let rec gameLoop () =  async {
        do! prompt "Click To Start" awaitClick                                    
        do! inGameLoop ()         
        do! prompt "Game Over" pause        
        well.Clear()
        return! gameLoop ()
        } 
    
    do  gameLoop() |> Async.StartImmediate

Run script on TryFSharp.org
#if INTERACTIVE
#else
module Game
#endif
namespace System
namespace System.Windows
namespace System.Media
type KeyState (control:Control) =
    let mutable keysDown = Set.empty
    let mutable keyUps = List.empty
    let addKey key () = keyUps <- key :: keyUps
    let readKeyUps key () =
        let ofKey, otherKeys =
            keyUps |> List.partition ((=) key)
        keyUps <- otherKeys
        List.length ofKey
    let sync = obj()
    do control.KeyDown.Add (fun e ->
            keysDown <- keysDown.Add e.Key
        )
    do control.KeyUp.Add (fun e ->
            keysDown <- keysDown.Remove e.Key
            lock sync (e.Key |> addKey)
        )
    member this.IsKeyDown key = keysDown.Contains key
    member this.IsAnyKeyDwn () = keysDown.Count > 0
    member this.ReadKeyPressed key =
        let keyUps = lock sync (key |> readKeyUps)
        keyUps > 0
    member this.ReadKeyPresses key =
        let keyUps = lock sync (key |> readKeyUps)
        keyUps + (if keysDown.Contains key then 1 else 0)
val tetrads : ((int * int) list * obj * obj) list

Full name: Script.tetrads
type Block =
  {X: int;
   Y: int;
   Rectangle: obj;}

Full name: Script.Block
Block.X: int
Multiple items
val int : value:'T -> int (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.int

--------------------
type int = int32

Full name: Microsoft.FSharp.Core.int

--------------------
type int<'Measure> = int

Full name: Microsoft.FSharp.Core.int<_>
Block.Y: int
Block.Rectangle: obj
type Tetrad =
  {Blocks: Block list;
   Canvas: obj;}

Full name: Script.Tetrad
Tetrad.Blocks: Block list
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
Tetrad.Canvas: obj
val setPosition : block:'a -> x:'b * y:'c -> 'd

Full name: Script.setPosition
val block : 'a
val x : 'b
val y : 'c
val blockSize : float

Full name: Script.blockSize
val toPosition : x:int * y:int -> float * float

Full name: Script.toPosition
val x : int
val y : int
Multiple items
val float : value:'T -> float (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.float

--------------------
type float = Double

Full name: Microsoft.FSharp.Core.float

--------------------
type float<'Measure> = float

Full name: Microsoft.FSharp.Core.float<_>
val positionBlock : block:Block -> 'a

Full name: Script.positionBlock
val block : Block
val positionBlocks : blocks:Block list -> unit

Full name: Script.positionBlocks
val blocks : Block list
Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
  interface IEnumerable
  interface IEnumerable<'T>
  member Head : 'T
  member IsEmpty : bool
  member Item : index:int -> 'T with get
  member Length : int
  member Tail : 'T list
  static member Cons : head:'T * tail:'T list -> 'T list
  static member Empty : 'T list

Full name: Microsoft.FSharp.Collections.List<_>
val iter : action:('T -> unit) -> list:'T list -> unit

Full name: Microsoft.FSharp.Collections.List.iter
val positionTetrad : tetrad:Tetrad -> x:int * y:int -> 'a

Full name: Script.positionTetrad
val tetrad : Tetrad
val createTetrad : coordinates:(int * int) list * stroke:'a * fill:'b -> Tetrad

Full name: Script.createTetrad
val coordinates : (int * int) list
val stroke : 'a
val fill : 'b
val createRectangle : (unit -> 'c)
val createBlocks : ((int * int) list -> Block list)
val map : mapping:('T -> 'U) -> list:'T list -> 'U list

Full name: Microsoft.FSharp.Collections.List.map
val rectangle : obj
val composeBlocks : ('c list -> 'd)
val blocks : 'c list
val canvas : 'd
val block : 'c
val canvas : obj
val wellWidth : int

Full name: Script.wellWidth
val wellHeight : int

Full name: Script.wellHeight
Multiple items
type Well =
  new : unit -> Well
  member AddBlock : x:int * y:int -> block:obj -> 'a
  member CheckLines : unit -> unit
  member Clear : unit -> unit
  member Control : obj
  member IsBlocked : (int * int -> bool)

Full name: Script.Well

--------------------
new : unit -> Well
val matrix : obj option [,]
module Array2D

from Microsoft.FSharp.Collections
val create : length1:int -> length2:int -> value:'T -> 'T [,]

Full name: Microsoft.FSharp.Collections.Array2D.create
union case Option.None: Option<'T>
val addBlock : (int * int -> obj -> 'a)
val block : obj
union case Option.Some: Value: 'T -> Option<'T>
val clear : (unit -> unit)
val iteri : action:(int -> int -> 'T -> unit) -> array:'T [,] -> unit

Full name: Microsoft.FSharp.Collections.Array2D.iteri
val block : obj option
module Option

from Microsoft.FSharp.Core
val iter : action:('T -> unit) -> option:'T option -> unit

Full name: Microsoft.FSharp.Core.Option.iter
val ignore : value:'T -> unit

Full name: Microsoft.FSharp.Core.Operators.ignore
val isBlocked : (int * int -> bool)
val exists : predicate:('T -> bool) -> option:'T option -> bool

Full name: Microsoft.FSharp.Core.Option.exists
val x : obj
val checkLines : (unit -> unit)
val lineBlockCounts : (int * int) list
val count : option:'T option -> int

Full name: Microsoft.FSharp.Core.Option.count
val reduce : reduction:('T -> 'T -> 'T) -> list:'T list -> 'T

Full name: Microsoft.FSharp.Collections.List.reduce
val clearLine : (int -> unit)
val fallDownTo : (int -> unit)
val i : int
val count : int
val well : Well
member Well.IsBlocked : (int * int -> bool)

Full name: Script.Well.IsBlocked
member Well.AddBlock : x:int * y:int -> block:obj -> 'a

Full name: Script.Well.AddBlock
member Well.CheckLines : unit -> unit

Full name: Script.Well.CheckLines
member Well.Clear : unit -> unit

Full name: Script.Well.Clear
Multiple items
member Well.Control : obj

Full name: Script.Well.Control

--------------------
namespace Microsoft.FSharp.Control
Multiple items
type GameControl =
  inherit obj
  new : unit -> GameControl

Full name: Script.GameControl

--------------------
new : unit -> GameControl
val this : GameControl
Multiple items
type KeyState =
  new : control:obj -> KeyState
  member IsAnyKeyDwn : unit -> bool
  member IsKeyDown : key:IComparable -> bool
  member ReadKeyPressed : key:IComparable -> bool
  member ReadKeyPresses : key:IComparable -> int

Full name: Script.KeyState

--------------------
new : control:obj -> KeyState
namespace Microsoft.FSharp.Control
val exists : predicate:('T -> bool) -> list:'T list -> bool

Full name: Microsoft.FSharp.Collections.List.exists
val sign : value:'T -> int (requires member get_Sign)

Full name: Microsoft.FSharp.Core.Operators.sign
val not : value:bool -> bool

Full name: Microsoft.FSharp.Core.Operators.not
val async : AsyncBuilder

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.async
Multiple items
val ref : value:'T -> 'T ref

Full name: Microsoft.FSharp.Core.Operators.ref

--------------------
type 'T ref = Ref<'T>

Full name: Microsoft.FSharp.Core.ref<_>
Multiple items
type Async
static member AsBeginEnd : computation:('Arg -> Async<'T>) -> ('Arg * AsyncCallback * obj -> IAsyncResult) * (IAsyncResult -> 'T) * (IAsyncResult -> unit)
static member AwaitEvent : event:IEvent<'Del,'T> * ?cancelAction:(unit -> unit) -> Async<'T> (requires delegate and 'Del :> Delegate)
static member AwaitIAsyncResult : iar:IAsyncResult * ?millisecondsTimeout:int -> Async<bool>
static member AwaitTask : task:Task<'T> -> Async<'T>
static member AwaitWaitHandle : waitHandle:WaitHandle * ?millisecondsTimeout:int -> Async<bool>
static member CancelDefaultToken : unit -> unit
static member Catch : computation:Async<'T> -> Async<Choice<'T,exn>>
static member FromBeginEnd : beginAction:(AsyncCallback * obj -> IAsyncResult) * endAction:(IAsyncResult -> 'T) * ?cancelAction:(unit -> unit) -> Async<'T>
static member FromBeginEnd : arg:'Arg1 * beginAction:('Arg1 * AsyncCallback * obj -> IAsyncResult) * endAction:(IAsyncResult -> 'T) * ?cancelAction:(unit -> unit) -> Async<'T>
static member FromBeginEnd : arg1:'Arg1 * arg2:'Arg2 * beginAction:('Arg1 * 'Arg2 * AsyncCallback * obj -> IAsyncResult) * endAction:(IAsyncResult -> 'T) * ?cancelAction:(unit -> unit) -> Async<'T>
static member FromBeginEnd : arg1:'Arg1 * arg2:'Arg2 * arg3:'Arg3 * beginAction:('Arg1 * 'Arg2 * 'Arg3 * AsyncCallback * obj -> IAsyncResult) * endAction:(IAsyncResult -> 'T) * ?cancelAction:(unit -> unit) -> Async<'T>
static member FromContinuations : callback:(('T -> unit) * (exn -> unit) * (OperationCanceledException -> unit) -> unit) -> Async<'T>
static member Ignore : computation:Async<'T> -> Async<unit>
static member OnCancel : interruption:(unit -> unit) -> Async<IDisposable>
static member Parallel : computations:seq<Async<'T>> -> Async<'T []>
static member RunSynchronously : computation:Async<'T> * ?timeout:int * ?cancellationToken:CancellationToken -> 'T
static member Sleep : millisecondsDueTime:int -> Async<unit>
static member Start : computation:Async<unit> * ?cancellationToken:CancellationToken -> unit
static member StartAsTask : computation:Async<'T> * ?taskCreationOptions:TaskCreationOptions * ?cancellationToken:CancellationToken -> Task<'T>
static member StartChild : computation:Async<'T> * ?millisecondsTimeout:int -> Async<Async<'T>>
static member StartChildAsTask : computation:Async<'T> * ?taskCreationOptions:TaskCreationOptions -> Async<Task<'T>>
static member StartImmediate : computation:Async<unit> * ?cancellationToken:CancellationToken -> unit
static member StartWithContinuations : computation:Async<'T> * continuation:('T -> unit) * exceptionContinuation:(exn -> unit) * cancellationContinuation:(OperationCanceledException -> unit) * ?cancellationToken:CancellationToken -> unit
static member SwitchToContext : syncContext:SynchronizationContext -> Async<unit>
static member SwitchToNewThread : unit -> Async<unit>
static member SwitchToThreadPool : unit -> Async<unit>
static member TryCancelled : computation:Async<'T> * compensation:(OperationCanceledException -> unit) -> Async<'T>
static member CancellationToken : Async<CancellationToken>
static member DefaultCancellationToken : CancellationToken

Full name: Microsoft.FSharp.Control.Async

--------------------
type Async<'T>

Full name: Microsoft.FSharp.Control.Async<_>
static member Async.Sleep : millisecondsDueTime:int -> Async<unit>
val incr : cell:int ref -> unit

Full name: Microsoft.FSharp.Core.Operators.incr
Multiple items
type Random =
  new : unit -> Random + 1 overload
  member Next : unit -> int + 2 overloads
  member NextBytes : buffer:byte[] -> unit
  member NextDouble : unit -> float

Full name: System.Random

--------------------
Random() : unit
Random(Seed: int) : unit
property List.Length: int
namespace System.Text
static member Async.AwaitEvent : event:IEvent<'Del,'T> * ?cancelAction:(unit -> unit) -> Async<'T> (requires delegate and 'Del :> Delegate)
static member Async.Ignore : computation:Async<'T> -> Async<unit>
static member Async.StartImmediate : computation:Async<unit> * ?cancellationToken:Threading.CancellationToken -> unit
#if INTERACTIVE
open Microsoft.TryFSharp
App.Dispatch (fun() ->
    App.Console.ClearCanvas()
    let canvas = App.Console.Canvas
    let control = GameControl()
    control |> canvas.Children.Add
    App.Console.CanvasPosition <- CanvasPosition.Right
    control.Focus() |> ignore
)
#endif

More information

Link:http://fssnip.net/5W
Posted:13 years ago
Author:Phillip Trelford
Tags: game , silverlight , async

This web site is created using F# and Suave web server. It is hosted on Azure and the source code is on GitHub. Contributions are welcome!

The first version of fssnip.net has been created by @tomaspetricek back in 2010. This web site is a new, open-source and contribution-friendly version.