├── .gitignore ├── screenshot.PNG ├── Content ├── block.png ├── white.png ├── Sounds │ ├── Drop.wav │ ├── Line.wav │ ├── Move.wav │ ├── Rotate.wav │ ├── Blocked.wav │ ├── GameOver.wav │ └── LevelUp.wav ├── coders_crux.ttf ├── Content.mgcb └── coders_crux.spritefont ├── Program.fs ├── .vscode ├── tasks.json └── launch.json ├── Controller.fs ├── license ├── Tetris.fsproj ├── Tetris.sln ├── View.fs ├── README.md ├── GameCore.fs └── Model.fs /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | /**/bin 3 | /**/obj 4 | /.vs 5 | project.lock.json -------------------------------------------------------------------------------- /screenshot.PNG: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ChrisPritchard/Tetris/HEAD/screenshot.PNG -------------------------------------------------------------------------------- /Content/block.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ChrisPritchard/Tetris/HEAD/Content/block.png -------------------------------------------------------------------------------- /Content/white.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ChrisPritchard/Tetris/HEAD/Content/white.png -------------------------------------------------------------------------------- /Content/Sounds/Drop.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ChrisPritchard/Tetris/HEAD/Content/Sounds/Drop.wav -------------------------------------------------------------------------------- /Content/Sounds/Line.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ChrisPritchard/Tetris/HEAD/Content/Sounds/Line.wav -------------------------------------------------------------------------------- /Content/Sounds/Move.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ChrisPritchard/Tetris/HEAD/Content/Sounds/Move.wav -------------------------------------------------------------------------------- /Content/coders_crux.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ChrisPritchard/Tetris/HEAD/Content/coders_crux.ttf -------------------------------------------------------------------------------- /Content/Sounds/Rotate.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ChrisPritchard/Tetris/HEAD/Content/Sounds/Rotate.wav -------------------------------------------------------------------------------- /Content/Sounds/Blocked.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ChrisPritchard/Tetris/HEAD/Content/Sounds/Blocked.wav -------------------------------------------------------------------------------- /Content/Sounds/GameOver.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ChrisPritchard/Tetris/HEAD/Content/Sounds/GameOver.wav -------------------------------------------------------------------------------- /Content/Sounds/LevelUp.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ChrisPritchard/Tetris/HEAD/Content/Sounds/LevelUp.wav -------------------------------------------------------------------------------- /Program.fs: -------------------------------------------------------------------------------- 1 | 2 | [] 3 | let main _ = 4 | use game = new GameCore.GameLoop(View.resolution, View.assetsToLoad, Controller.advanceGame, View.getView) 5 | game.Run () 6 | 0 -------------------------------------------------------------------------------- /.vscode/tasks.json: -------------------------------------------------------------------------------- 1 | { 2 | // See https://go.microsoft.com/fwlink/?LinkId=733558 3 | // for the documentation about the tasks.json format 4 | "version": "2.0.0", 5 | "tasks": [ 6 | { 7 | "label": "build", 8 | "command": "dotnet build", 9 | "type": "shell", 10 | "group": "build", 11 | "presentation": { 12 | "reveal": "silent" 13 | }, 14 | "problemMatcher": "$msCompile" 15 | } 16 | ] 17 | } -------------------------------------------------------------------------------- /.vscode/launch.json: -------------------------------------------------------------------------------- 1 | { 2 | // Use IntelliSense to learn about possible attributes. 3 | // Hover to view descriptions of existing attributes. 4 | // For more information, visit: https://go.microsoft.com/fwlink/?linkid=830387 5 | "version": "0.2.0", 6 | "configurations": [ 7 | { 8 | "name": "Debug", 9 | "type": "coreclr", 10 | "request": "launch", 11 | "preLaunchTask": "build", 12 | "program": "${workspaceFolder}/bin/Debug/netcoreapp2.1/Tetris.dll", 13 | "args": [], 14 | "cwd": "${workspaceFolder}", 15 | "console": "internalConsole", 16 | "stopAtEntry": false, 17 | "internalConsoleOptions": "openOnSessionStart" 18 | } 19 | ] 20 | } -------------------------------------------------------------------------------- /Controller.fs: -------------------------------------------------------------------------------- 1 | module Controller 2 | open Model 3 | open GameCore 4 | open Microsoft.Xna.Framework.Input 5 | 6 | let keyMap = 7 | function 8 | | Keys.Left -> Some Command.Left 9 | | Keys.Right -> Some Command.Right 10 | | Keys.Up -> Some Command.Rotate 11 | | _ -> None 12 | 13 | let initModel elapsed = 14 | Some { startModel with lastDropTime = elapsed; lastCommandTime = elapsed } 15 | 16 | let advanceGame (runState: RunState) gameModel = 17 | match gameModel with 18 | | None -> 19 | initModel runState.elapsed 20 | | Some _ when runState.WasJustPressed Keys.Escape -> 21 | None 22 | | Some m when m.isGameOver && runState.WasJustPressed Keys.R -> 23 | initModel runState.elapsed 24 | | Some m when m.isGameOver -> 25 | Some { m with events = [] } 26 | | Some m -> 27 | let command = List.map keyMap runState.keyboard.pressed |> List.tryPick id 28 | let isDropPressed = List.contains Keys.Down runState.keyboard.pressed 29 | Model.advanceGame runState.elapsed command isDropPressed m |> Some -------------------------------------------------------------------------------- /license: -------------------------------------------------------------------------------- 1 | This is free and unencumbered software released into the public domain. 2 | 3 | Anyone is free to copy, modify, publish, use, compile, sell, or 4 | distribute this software, either in source code form or as a compiled 5 | binary, for any purpose, commercial or non-commercial, and by any 6 | means. 7 | 8 | In jurisdictions that recognize copyright laws, the author or authors 9 | of this software dedicate any and all copyright interest in the 10 | software to the public domain. We make this dedication for the benefit 11 | of the public at large and to the detriment of our heirs and 12 | successors. We intend this dedication to be an overt act of 13 | relinquishment in perpetuity of all present and future rights to this 14 | software under copyright law. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 19 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | For more information, please refer to -------------------------------------------------------------------------------- /Content/Content.mgcb: -------------------------------------------------------------------------------- 1 | 2 | #----------------------------- Global Properties ----------------------------# 3 | 4 | /outputDir:bin 5 | /intermediateDir:obj 6 | /platform:Windows 7 | /config: 8 | /profile:Reach 9 | /compress:False 10 | 11 | #-------------------------------- References --------------------------------# 12 | 13 | 14 | #---------------------------------- Content ---------------------------------# 15 | 16 | #begin block.png 17 | /importer:TextureImporter 18 | /processor:TextureProcessor 19 | /processorParam:ColorKeyColor=255,0,255,255 20 | /processorParam:ColorKeyEnabled=True 21 | /processorParam:GenerateMipmaps=False 22 | /processorParam:PremultiplyAlpha=True 23 | /processorParam:ResizeToPowerOfTwo=False 24 | /processorParam:MakeSquare=False 25 | /processorParam:TextureFormat=Color 26 | /build:block.png 27 | 28 | #begin coders_crux.spritefont 29 | /importer:FontDescriptionImporter 30 | /processor:FontDescriptionProcessor 31 | /processorParam:PremultiplyAlpha=True 32 | /processorParam:TextureFormat=Compressed 33 | /build:coders_crux.spritefont 34 | 35 | #begin white.png 36 | /importer:TextureImporter 37 | /processor:TextureProcessor 38 | /processorParam:ColorKeyColor=255,0,255,255 39 | /processorParam:ColorKeyEnabled=True 40 | /processorParam:GenerateMipmaps=False 41 | /processorParam:PremultiplyAlpha=True 42 | /processorParam:ResizeToPowerOfTwo=False 43 | /processorParam:MakeSquare=False 44 | /processorParam:TextureFormat=Color 45 | /build:white.png 46 | 47 | -------------------------------------------------------------------------------- /Tetris.fsproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Exe 5 | netcoreapp2.1 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 | -------------------------------------------------------------------------------- /Tetris.sln: -------------------------------------------------------------------------------- 1 | 2 | Microsoft Visual Studio Solution File, Format Version 12.00 3 | # Visual Studio 15 4 | VisualStudioVersion = 15.0.26124.0 5 | MinimumVisualStudioVersion = 15.0.26124.0 6 | Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Tetris", "Tetris.fsproj", "{F856CDCC-F582-4C77-8432-14B5F5E73785}" 7 | EndProject 8 | Global 9 | GlobalSection(SolutionConfigurationPlatforms) = preSolution 10 | Debug|Any CPU = Debug|Any CPU 11 | Debug|x64 = Debug|x64 12 | Debug|x86 = Debug|x86 13 | Release|Any CPU = Release|Any CPU 14 | Release|x64 = Release|x64 15 | Release|x86 = Release|x86 16 | EndGlobalSection 17 | GlobalSection(SolutionProperties) = preSolution 18 | HideSolutionNode = FALSE 19 | EndGlobalSection 20 | GlobalSection(ProjectConfigurationPlatforms) = postSolution 21 | {F856CDCC-F582-4C77-8432-14B5F5E73785}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 22 | {F856CDCC-F582-4C77-8432-14B5F5E73785}.Debug|Any CPU.Build.0 = Debug|Any CPU 23 | {F856CDCC-F582-4C77-8432-14B5F5E73785}.Debug|x64.ActiveCfg = Debug|Any CPU 24 | {F856CDCC-F582-4C77-8432-14B5F5E73785}.Debug|x64.Build.0 = Debug|Any CPU 25 | {F856CDCC-F582-4C77-8432-14B5F5E73785}.Debug|x86.ActiveCfg = Debug|Any CPU 26 | {F856CDCC-F582-4C77-8432-14B5F5E73785}.Debug|x86.Build.0 = Debug|Any CPU 27 | {F856CDCC-F582-4C77-8432-14B5F5E73785}.Release|Any CPU.ActiveCfg = Release|Any CPU 28 | {F856CDCC-F582-4C77-8432-14B5F5E73785}.Release|Any CPU.Build.0 = Release|Any CPU 29 | {F856CDCC-F582-4C77-8432-14B5F5E73785}.Release|x64.ActiveCfg = Release|Any CPU 30 | {F856CDCC-F582-4C77-8432-14B5F5E73785}.Release|x64.Build.0 = Release|Any CPU 31 | {F856CDCC-F582-4C77-8432-14B5F5E73785}.Release|x86.ActiveCfg = Release|Any CPU 32 | {F856CDCC-F582-4C77-8432-14B5F5E73785}.Release|x86.Build.0 = Release|Any CPU 33 | EndGlobalSection 34 | EndGlobal 35 | -------------------------------------------------------------------------------- /Content/coders_crux.spritefont: -------------------------------------------------------------------------------- 1 | 2 | 8 | 9 | 10 | 11 | 14 | coders_crux.ttf 15 | 16 | 20 | 50 21 | 22 | 26 | 0 27 | 28 | 32 | true 33 | 34 | 38 | 39 | 40 | 44 | 45 | 46 | 53 | 54 | 55 | 56 | ~ 57 | 58 | 59 | 60 | -------------------------------------------------------------------------------- /View.fs: -------------------------------------------------------------------------------- 1 | module View 2 | 3 | open GameCore 4 | open Model 5 | open Microsoft.Xna.Framework 6 | 7 | let rw, rh = 400, 600 8 | let resolution = Windowed (rw, rh) 9 | 10 | let assetsToLoad = [ 11 | Texture { key = "blank"; path = "Content/white" } 12 | Texture { key = "block"; path = "Content/block" } 13 | Font { key = "default"; path = "Content/coders_crux" } 14 | Sound { key = "blocked"; path = "Content/Sounds/Blocked.wav" } 15 | Sound { key = "drop"; path = "Content/Sounds/Drop.wav" } 16 | Sound { key = "gameOver"; path = "Content/Sounds/GameOver.wav" } 17 | Sound { key = "levelUp"; path = "Content/Sounds/LevelUp.wav" } 18 | Sound { key = "line"; path = "Content/Sounds/Line.wav" } 19 | Sound { key = "move"; path = "Content/Sounds/Move.wav" } 20 | Sound { key = "rotate"; path = "Content/Sounds/Rotate.wav" } 21 | ] 22 | 23 | // Block size 24 | let bw, bh = 25, 25 25 | // Game space 26 | let gx, gy, gw, gh = 10, 10, 250, 500 27 | // Next block space 28 | let nx, ny, nw, nh = 270, 10, 120, 70 29 | // Game over space 30 | let gameOverSpace = 20, 200, 360, 100 31 | 32 | let textScale = 0.5 33 | let textHeight = 20 34 | // Score text 35 | let sx, sy = nx + (nw / 2), ny + nh + 20 36 | // Level text 37 | let lx, ly = sx, sy + 60 38 | // Instruction text 39 | let ix, iy = rw / 2, gy + gh + 30 40 | // Game over text 41 | let gox, goy = 200, 230 42 | 43 | let eventSoundMap = 44 | function 45 | | Moved -> "move" 46 | | Rotated -> "rotate" 47 | | Dropped -> "drop" 48 | | Line -> "line" 49 | | LevelUp -> "levelUp" 50 | | Blocked -> "blocked" 51 | | GameOver -> "gameOver" 52 | 53 | let colorFor colour = 54 | match colour with 55 | | Red -> Color.Red | Magenta -> Color.Magenta | Yellow -> Color.Yellow 56 | | Cyan -> Color.Cyan | Blue -> Color.Blue | Silver -> Color.Silver | Green -> Color.Green 57 | 58 | let posFor (x,y) (ox, oy) = 59 | x * bw + ox, y * bh + oy, bw, bh 60 | 61 | let getView _ (model: World) = 62 | let gameSpace = [ 63 | ColouredImage (Color.Black, { assetKey = "blank"; destRect = gx-1, gy-1, gw+2, gh+2; sourceRect = None }) 64 | ColouredImage (Color.Gray, { assetKey = "blank"; destRect = gx, gy, gw, gh; sourceRect = None }) 65 | ] 66 | 67 | let nextBlockSpace = [ 68 | ColouredImage (Color.Black, { assetKey = "blank"; destRect = nx-1, ny-1, nw+2, nh+2; sourceRect = None }) 69 | ColouredImage (Color.Gray, { assetKey = "blank"; destRect = nx, ny, nw, nh; sourceRect = None }) 70 | ] 71 | 72 | let lines = 73 | match model.linesToRemove with 74 | | Some lines -> lines |> List.map (fun (_,_,y) -> y) 75 | | _ -> [] 76 | let staticBlocks = 77 | model.staticBlocks 78 | |> List.map (fun (c,x,y) -> 79 | let color = if List.contains y lines then Color.White else colorFor c 80 | ColouredImage (color, { assetKey = "block"; destRect = posFor (x,y) (gx, gy); sourceRect = None })) 81 | 82 | let currentShape = 83 | match model.shape with 84 | | Some (colour, blocks) -> 85 | plot model.pos blocks 86 | |> List.map (fun (x,y) -> 87 | ColouredImage (colorFor colour, { assetKey = "block"; destRect = posFor (x,y) (gx, gy); sourceRect = None })) 88 | | _ -> [] 89 | 90 | let nextColour = colorFor <| fst model.nextShape 91 | let nsw, nsh = snd model.nextShape |> List.head |> List.length, snd model.nextShape |> List.length 92 | let nsow, nsoh = (nw - (nsw * bw)) / 2, (nh - (nsh * bh)) / 2 93 | let nextShape = 94 | plot (0, 0) <| snd model.nextShape 95 | |> List.map (fun (x,y) -> 96 | ColouredImage (nextColour, { assetKey = "block"; destRect = posFor (x,y) (nx + nsow, ny + nsoh); sourceRect = None })) 97 | 98 | let baseText = { assetKey = "default"; text = ""; position = (0, 0); origin = Centre; scale = textScale } 99 | let text = [ 100 | Text { baseText with text = "Score"; position = (sx, sy) } 101 | Text { baseText with text = string model.score; position = (sx, sy + textHeight) } 102 | 103 | Text { baseText with text = "Level"; position = (lx, ly) } 104 | Text { baseText with text = string model.level; position = (lx, ly + textHeight) } 105 | 106 | Text { baseText with text = "Instructions"; position = (ix, iy) } 107 | Text { baseText with scale = 0.4; text = "left to move left, right to move right"; position = (ix, iy + textHeight) } 108 | Text { baseText with scale = 0.4; text = "up to rotate, down to drop"; position = (ix, iy + textHeight + textHeight) } 109 | ] 110 | 111 | let gameOver = 112 | if model.isGameOver then [ 113 | ColouredImage (Color.Black, { assetKey = "blank"; destRect = gameOverSpace; sourceRect = None }) 114 | ColouredText (Color.White, { baseText with scale = 0.7; text = "Game Over!"; position = (gox, goy) }) 115 | ColouredText (Color.White, { baseText with text = "Press R to restart"; position = (gox, goy + textHeight + textHeight) }) 116 | ] else [] 117 | 118 | let sounds = model.events |> List.map (eventSoundMap >> SoundEffect) 119 | 120 | gameSpace @ nextBlockSpace @ staticBlocks @ currentShape @ nextShape @ text @ gameOver @ sounds -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Tetris 2 | 3 | Classic tetris, implemented in F# with MonoGame. An exercise in functional programming and game solution design. 4 | 5 |

6 | screenshot 7 |

8 | 9 | ## Supported platforms 10 | 11 | Being dotnet core 2.1, it should work on all platforms that supports (Windows, Linux, Mac). Tested (and largely coded on) Windows 10. A full list of dotnet core supported platforms can be found from here: 12 | 13 | I built this using VS Code, but have also tested opening and running on Visual Studio 2017. 14 | 15 | A note for mac users: part of the compilation of this game involves building the content, done using a MonoGame content builder referenced via Nuget. On OSX, this component does not work with just dotnet core. I have managed to get it going by doing the following: 16 | 17 | - Installing the latest version of LTS Mono from here (version 5.12.0): 18 | - Installing the latest version of the MonoGame standalone pipeline builder for OSX from here (Pipeline.MacOS.pkg, v3.6): 19 | - Doing a sudo dotnet restore and a sudo dotnet build 20 | 21 | After the build succeeded, a sudo dotnet run started the game without issue. 22 | 23 | ## Acknowledgements 24 | 25 | The game and code is Unilicense, but I have used two sets of external resources: 26 | 27 | - The font is called "Coders Crux" and is from here: 28 | - The sounds were acquired from here: 29 | 30 | Unfortunately I got this sound set a long time ago (five plus years) and can't find the exact provenance. 31 | 32 | ## Guide to components 33 | 34 | The five code files in this project are described below, in decreasing game importance. Aside from code, there is also the Content folder which contains images, sounds, fonts etc and the Content.mgcb file, which MonoGame uses to compile assets into the game exe. This compilation is triggered by a line in the Tetris.fsproj file (MonoGameContentReference Include="**\*.mgcb") and done by the builder referenced as a nuget package (MonoGame.Content.Builder). Should be automatic on build (though sometimes you need to build twice). 35 | 36 | ### Model.fs 37 | 38 | This file contains a pure F# representation of Tetris: types and DUs to represent the current game state, and functions to transition from one state to the next. It knows nothing of MonoGame, of inputs, resolutions or views - even Colour is an enum defined in Model.fs (which is later translated by View.fs) 39 | 40 | The top of the file contains constants for the game, like score amounts, the game width, shape templates etc. The bulk of the file contains methods for transitioning different parts of the state, like processCommand and drop, while the final method AdvanceGame is the primary point of entry. This final method takes the previous/current state, an optional command (translated from Keys by Controller.fs) and an elapsed game time, and returns a new state. 41 | 42 | ### Controller.fs 43 | 44 | The controller's job is to control when the Model should be advanced, and to feed inputs into it. Primarily, if the game isnt over it will map user keys to Model commands, and pass through the current game time to the controller. Ultimately, the tiny Controller.fs file could be buried in Model.fs if it wasnt for a desire to keep Model.fs purity and hide the MonoGame keys construct. By splitting these out, how the game is controlled becomes an abstraction: blocks could be rotated or moved with the mouse if necessary, by modifying Controller.fs alone. 45 | 46 | ### View.fs 47 | 48 | If Controller.fs was about inputs, then View.fs is about outputs. It takes a model, and translates it to rendered sprites on the screen and sounds to be played. Despite this job, it is still largely agnostic of XNA, translating the model to abstractions which the GameLoop then uses. It is aware of the MonoGame colour construct, however, as mentioned. 49 | 50 | ### GameCore.fs 51 | 52 | GameCore is where all the MonoGame stuff is kept, and is basically the MonoGame.Game game loop class plus a bunch of abstraction types used to keep the other files pure. MonoGame is a class-based, imperative game development framework, that needs mutable types aplenty to work, and in order to keep my game largely free of these impurities, its all buried in here. GameLoop, the key class, is given the entry methods and model type from the other files, and orchestrates them. It could be viewed as the Imperative shell of the game. 53 | 54 | ### Program.fs 55 | 56 | This instantiates the GameLoop, passing through the methods and types from the other files, and handles disposal 57 | 58 | ## CoreRT 59 | 60 | There is a branch of this project called corert, that has CoreRT enabled. This has been tested to build on Windows, if you have the necessary requisites installed. Feel free to try it, but for support on getting it to build on Windows or Linux/OSX you will need to seek help at the [CoreRT site](https://github.com/dotnet/corert). 61 | 62 | ## Note on development sequence 63 | 64 | This project was the first developed after __Battleship__ [here](https://github.com/ChrisPritchard/Battleship). 65 | 66 | The next project developed after this, and using the lessons learned, was __MiniKnight__ [here](https://github.com/ChrisPritchard/MiniKnight). -------------------------------------------------------------------------------- /GameCore.fs: -------------------------------------------------------------------------------- 1 | module GameCore 2 | 3 | open System 4 | open System.IO 5 | open Microsoft.Xna.Framework 6 | open Microsoft.Xna.Framework.Graphics; 7 | open Microsoft.Xna.Framework.Input; 8 | open Microsoft.Xna.Framework.Audio 9 | 10 | type KeyPath = { 11 | key: string 12 | path: string 13 | } 14 | 15 | type Loadable = 16 | | Texture of KeyPath 17 | | Font of KeyPath 18 | | Sound of KeyPath 19 | 20 | type Origin = | TopLeft | Centre 21 | 22 | type DrawImageInfo = { 23 | assetKey: string 24 | destRect: int * int * int * int 25 | sourceRect: (int * int * int * int) option 26 | } 27 | 28 | type DrawTextInfo = { 29 | assetKey: string 30 | text: string 31 | position: int * int 32 | origin: Origin 33 | scale: float 34 | } 35 | 36 | type ViewArtifact = 37 | | Image of DrawImageInfo 38 | | ColouredImage of Color * DrawImageInfo 39 | | Text of DrawTextInfo 40 | | ColouredText of Color * DrawTextInfo 41 | | SoundEffect of string 42 | 43 | type Resolution = 44 | | Windowed of int * int 45 | | FullScreen of int * int 46 | 47 | type private Content = 48 | | TextureAsset of Texture2D 49 | | FontAsset of SpriteFont 50 | | SoundAsset of SoundEffect 51 | 52 | type RunState = { 53 | elapsed: float 54 | keyboard: KeyboardInfo 55 | mouse: MouseInfo 56 | } and KeyboardInfo = { 57 | pressed: Keys list; 58 | keysDown: Keys list; 59 | keysUp: Keys list 60 | } and MouseInfo = { 61 | position: int * int 62 | pressed: bool * bool 63 | } 64 | 65 | type RunState with 66 | member __.WasJustPressed key = List.contains key __.keyboard.keysDown 67 | 68 | type GameLoop<'TModel> (resolution, assetsToLoad, updateModel, getView) 69 | as this = 70 | inherit Game() 71 | 72 | let mutable graphics = new GraphicsDeviceManager(this) 73 | 74 | let mutable assets = Map.empty 75 | 76 | let mutable keyboardInfo = { pressed = []; keysDown = []; keysUp = [] } 77 | let mutable currentModel: 'TModel option = None 78 | let mutable currentView: ViewArtifact list = [] 79 | 80 | let mutable spriteBatch = Unchecked.defaultof 81 | 82 | do 83 | match resolution with 84 | | FullScreen (w,h) -> 85 | graphics.PreferredBackBufferWidth <- w 86 | graphics.PreferredBackBufferHeight <- h 87 | graphics.IsFullScreen <- true 88 | | Windowed (w,h) -> 89 | graphics.PreferredBackBufferWidth <- w 90 | graphics.PreferredBackBufferHeight <- h 91 | 92 | let updateKeyboardInfo (keyboard: KeyboardState) (existing: KeyboardInfo) = 93 | let pressed = keyboard.GetPressedKeys() |> Set.ofArray 94 | { 95 | pressed = pressed |> Set.toList 96 | keysDown = Set.difference pressed (existing.pressed |> Set.ofList) |> Set.toList 97 | keysUp = Set.difference (existing.pressed |> Set.ofList) pressed |> Set.toList 98 | } 99 | 100 | let getMouseInfo (mouse: MouseState) = 101 | { 102 | position = mouse.X, mouse.Y 103 | pressed = mouse.LeftButton = ButtonState.Pressed, mouse.RightButton = ButtonState.Pressed 104 | } 105 | 106 | let asVector2 (x,y) = new Vector2(float32 x, float32 y) 107 | let asRectangle (x,y,width,height) = 108 | new Rectangle (x,y,width,height) 109 | 110 | let drawImage (spriteBatch: SpriteBatch) image colour = 111 | let sourceRect = 112 | match image.sourceRect with 113 | | None -> Unchecked.defaultof> 114 | | Some r -> asRectangle r |> Nullable 115 | let texture = 116 | match Map.tryFind image.assetKey assets with 117 | | Some (TextureAsset t) -> t 118 | | None -> sprintf "Missing asset: %s" image.assetKey |> failwith 119 | | _-> sprintf "Asset was not a Texture2D: %s" image.assetKey |> failwith 120 | spriteBatch.Draw( 121 | texture, asRectangle image.destRect, 122 | sourceRect, colour, 0.0f, Vector2.Zero, 123 | SpriteEffects.None, 0.0f) 124 | 125 | let drawText (spriteBatch: SpriteBatch) text colour = 126 | let font = 127 | match Map.tryFind text.assetKey assets with 128 | | Some (FontAsset f) -> f 129 | | None -> sprintf "Missing asset: %s" text.assetKey |> failwith 130 | | _-> sprintf "Asset was not a SpriteFont: %s" text.assetKey |> failwith 131 | let position = 132 | match text.origin with 133 | | TopLeft -> asVector2 text.position 134 | | Centre -> 135 | let size = Vector2.Divide (font.MeasureString(text.text), 2.f / float32 text.scale) 136 | Vector2.Subtract (asVector2 text.position, size) 137 | spriteBatch.DrawString( 138 | font, text.text, position, colour, 139 | 0.0f, Vector2.Zero, float32 text.scale, SpriteEffects.None, 0.5f) 140 | 141 | let playSound assetKey = 142 | let sound = 143 | match Map.tryFind assetKey assets with 144 | | Some (SoundAsset s) -> s 145 | | None -> sprintf "Missing asset: %s" assetKey |> failwith 146 | | _ -> sprintf "Asset was not a SoundEffect: %s" assetKey |> failwith 147 | sound.Play () |> ignore 148 | 149 | override __.LoadContent() = 150 | spriteBatch <- new SpriteBatch(this.GraphicsDevice) 151 | assets <- 152 | assetsToLoad 153 | |> List.map ( 154 | function 155 | | Texture info -> info.key, this.Content.Load(info.path) |> TextureAsset 156 | | Font info -> info.key, this.Content.Load(info.path) |> FontAsset 157 | | Sound info -> 158 | use stream = File.OpenRead(info.path) 159 | info.key, SoundEffect.FromStream(stream) |> SoundAsset) 160 | |> Map.ofList 161 | 162 | override __.Update(gameTime) = 163 | keyboardInfo <- updateKeyboardInfo (Keyboard.GetState()) keyboardInfo 164 | let mouseInfo = getMouseInfo (Mouse.GetState()) 165 | let runState = { 166 | elapsed = gameTime.TotalGameTime.TotalMilliseconds 167 | keyboard = keyboardInfo 168 | mouse = mouseInfo 169 | } 170 | 171 | currentModel <- updateModel runState currentModel 172 | match currentModel with 173 | | None -> __.Exit() 174 | | Some model -> 175 | currentView <- getView runState model 176 | 177 | override __.Draw(_) = 178 | this.GraphicsDevice.Clear Color.White 179 | 180 | spriteBatch.Begin(SpriteSortMode.Deferred, BlendState.AlphaBlend, SamplerState.PointClamp) 181 | 182 | currentView 183 | |> List.iter ( 184 | function 185 | | Image i -> drawImage spriteBatch i Color.White 186 | | ColouredImage (c,i) -> drawImage spriteBatch i c 187 | | Text t -> drawText spriteBatch t Color.Black 188 | | ColouredText (c,t) -> drawText spriteBatch t c 189 | | SoundEffect s -> playSound s) 190 | 191 | spriteBatch.End() -------------------------------------------------------------------------------- /Model.fs: -------------------------------------------------------------------------------- 1 | module Model 2 | 3 | let width, height = 10, 20 4 | let startPos = (width / 2 - 1, 0) 5 | let scorePerLine = 100 6 | let scorePerLevel = 1000 7 | 8 | let timeBetweenCommands = 200. 9 | let timeBetweenLines = 1000. 10 | let timeBetweenDrops = 1000. 11 | let minDropTime = 100. 12 | let levelAdjustOnDropTime = 100. 13 | 14 | let random = new System.Random () 15 | 16 | type World = { 17 | score: int 18 | level: int 19 | isGameOver: bool 20 | 21 | lastCommandTime: float 22 | lastDropTime: float 23 | lastLineTime: float 24 | linesToRemove: (Colour * int * int) list option 25 | 26 | staticBlocks: (Colour * int * int) list 27 | pos: int * int 28 | shape: (Colour * ShapeBlock list list) option 29 | nextShape: Colour * ShapeBlock list list 30 | events: Event list 31 | } 32 | and ShapeBlock = | X | O 33 | and Colour = | Red | Magenta | Yellow | Cyan | Blue | Silver | Green 34 | and Event = | Moved | Rotated | Blocked | Dropped | Line | LevelUp | GameOver 35 | and Command = | Left | Right | Rotate 36 | 37 | let shapes = [ 38 | Cyan, [ 39 | [X;X] 40 | [X;X] 41 | ] 42 | Red, [ 43 | [X;X;X;X] 44 | ] 45 | Green, [ 46 | [X;X;O] 47 | [O;X;X] 48 | ] 49 | Blue, [ 50 | [O;X;X] 51 | [X;X;O] 52 | ] 53 | Yellow, [ 54 | [X;X;X] 55 | [X;O;O] 56 | ] 57 | Magenta, [ 58 | [X;X;X] 59 | [O;O;X] 60 | ] 61 | Silver, [ 62 | [X;X;X] 63 | [O;X;O] 64 | ] 65 | ] 66 | 67 | let randomShape () = shapes.[random.Next(shapes.Length)] 68 | 69 | let startModel = { 70 | score = 0 71 | level = 0 72 | isGameOver = false 73 | 74 | lastCommandTime = 0. 75 | lastDropTime = 0. 76 | lastLineTime = 0. 77 | linesToRemove = None 78 | 79 | staticBlocks = [] 80 | pos = startPos 81 | shape = randomShape () |> Some 82 | nextShape = randomShape () 83 | events = [] 84 | } 85 | 86 | let rec rotate = function 87 | | (_::_)::_ as m -> 88 | (List.map List.head m |> List.rev)::(List.map List.tail m |> rotate) 89 | | _ -> [] 90 | 91 | let plot (tlx, tly) = 92 | List.mapi (fun y -> 93 | List.mapi (fun x -> function 94 | | X -> (x + tlx, y + tly) |> Some 95 | | O -> None) >> List.choose id) >> List.concat 96 | 97 | let isOutOfBounds blocks = 98 | blocks |> List.exists (fun (x,y) -> x < 0 || x >= width || y < 0 || y >= height) 99 | 100 | let isOverlapping blocks world = 101 | let worldBlocks = world.staticBlocks |> List.map (fun (_,x,y) -> x,y) 102 | List.except worldBlocks blocks <> blocks 103 | 104 | let processCommand elapsed command world = 105 | match command with 106 | | None -> world 107 | | Some c -> 108 | match world.shape with 109 | | None -> world 110 | | Some _ when elapsed - world.lastCommandTime < timeBetweenCommands -> world 111 | | Some (colour, blocks) -> 112 | let (x, y) = world.pos 113 | let (nx, ny) = 114 | match c with 115 | | Left -> (x - 1, y) 116 | | Right -> (x + 1, y) 117 | | Rotate -> (x, y) 118 | 119 | let newShape = blocks |> match c with | Rotate -> rotate | _ -> id 120 | let newBlocks = plot (nx, ny) newShape 121 | 122 | if isOutOfBounds newBlocks || isOverlapping newBlocks world then 123 | { world with events = Blocked::world.events } 124 | else 125 | let event = 126 | match c with 127 | | Rotate -> Rotated 128 | | Left | Right -> Moved 129 | { world with 130 | shape = Some (colour, newShape) 131 | pos = (nx, ny) 132 | events = event::world.events 133 | lastCommandTime = elapsed } 134 | 135 | let drop elapsed isDropKeyPressed world = 136 | match world.shape with 137 | | None -> world 138 | | Some _ when 139 | let timeBetweenDrops = 140 | if isDropKeyPressed then minDropTime 141 | else timeBetweenDrops - (float world.level * levelAdjustOnDropTime) |> max minDropTime 142 | elapsed - world.lastDropTime < timeBetweenDrops -> world 143 | | Some (colour, blocks) -> 144 | let (x, y) = world.pos 145 | let newPos = (x, y + 1) 146 | 147 | let newBlocks = plot newPos blocks 148 | if not (isOutOfBounds newBlocks) && not (isOverlapping newBlocks world) then 149 | { world with pos = newPos; lastDropTime = elapsed; events = Dropped::world.events } 150 | else 151 | let currentBlocks = plot world.pos blocks |> List.map (fun (x,y) -> colour, x, y) 152 | { world with staticBlocks = world.staticBlocks @ currentBlocks; shape = None } 153 | 154 | let nextShape world = 155 | match world.shape with 156 | | Some _ -> world 157 | | None -> 158 | let nextBlocks = snd world.nextShape |> plot startPos 159 | let isGameOver = isOverlapping nextBlocks world 160 | { world with 161 | events = if isGameOver then [GameOver] else world.events 162 | isGameOver = isGameOver 163 | pos = startPos 164 | shape = Some world.nextShape 165 | nextShape = randomShape () } 166 | 167 | let getLines world = 168 | world.staticBlocks 169 | |> List.groupBy (fun (_,_,y) -> y) 170 | |> List.filter (fun r -> List.length (snd r) = width) 171 | |> List.collect snd 172 | 173 | let removeLines elapsed world = 174 | match world.linesToRemove with 175 | | None -> world 176 | | Some lines -> 177 | let newScore = List.length lines / width * scorePerLine |> (+) world.score 178 | let newLevel = float newScore / float scorePerLevel |> floor |> int 179 | 180 | let horizontals = lines |> List.map (fun (_,_,y) -> y) |> List.distinct 181 | let newBlocks = 182 | List.except lines world.staticBlocks 183 | |> List.map (fun (c, x, y) -> 184 | let adjust = y::horizontals |> List.sortByDescending id |> List.findIndex ((=) y) 185 | c, x, (y + adjust)) 186 | 187 | { world with 188 | staticBlocks = newBlocks 189 | score = newScore 190 | level = newLevel 191 | events = if newLevel <> world.level then LevelUp::world.events else world.events 192 | lastDropTime = elapsed 193 | lastCommandTime = elapsed 194 | linesToRemove = None } 195 | 196 | let advanceGame elapsed command isDropPressed world = 197 | if elapsed - world.lastLineTime < timeBetweenLines then 198 | { world with events = [] } 199 | else 200 | let result = 201 | { world with events = [] } 202 | |> removeLines elapsed 203 | |> nextShape 204 | |> processCommand elapsed command 205 | |> drop elapsed isDropPressed 206 | let lines = getLines result 207 | if List.isEmpty lines then result else 208 | { result with 209 | events = Line::world.events 210 | lastLineTime = elapsed 211 | linesToRemove = Some lines } --------------------------------------------------------------------------------