Skip to content

Instantly share code, notes, and snippets.

@mrange
Created March 10, 2024 14:32
Show Gist options
  • Save mrange/9e50f091bb3423ba5ce7f5b2ea73891c to your computer and use it in GitHub Desktop.
Save mrange/9e50f091bb3423ba5ce7f5b2ea73891c to your computer and use it in GitHub Desktop.
F# Bombs away
open System
open System.Globalization
open System.Windows
open System.Windows.Media
open System.Windows.Threading
open FSharp.Core.Printf
type CellSymbol =
| Empty
| Flag
| Bomb
type Cell =
| Covered of CellSymbol*bool
| Uncovering of bool
| Uncovered of int
| Exploding
| Exploded
module Common =
let inline between x b t = x >= b && x <= t
let inline clamp x b t = min (max x b) t
open Common
type PlayState = {
Width : int
Height : int
Cells : Cell array
}
with
member inline ps.CellPos i =
let i = clamp i 0 (ps.Cells.Length - 1)
i%ps.Width, i/ps.Width
#if DEBUG
member ps.VisitNeighbours x y f =
#else
member inline ps.VisitNeighbours x y ([<InlineIfLambda>] f) =
#endif
let w = ps.Width
for yy = y-1 to y+1 do
if between yy 0 (ps.Height - 1) then
for xx = x-1 to x+1 do
let same = x = xx && y = yy
if not same && between xx 0 (ps.Width - 1) then
f xx yy (xx + yy*w)
type GameState =
| Playing of PlayState
type GameArea = {
State : PlayState
Left : float
Top : float
Right : float
Bottom: float
Width : float
Height: float
Dim : float
DpiX : float
DpiY : float
}
with
member inline ga.CellPosFromIndex i =
let x, y = ga.State.CellPos i
ga.Left+ga.Dim*float x, ga.Top+ga.Dim*float y
member inline ga.QueryIndexFromCellPos x y =
let nx = int ((x-ga.Left)/ga.Dim)
let ny = int ((y-ga.Top)/ga.Dim)
if between nx 0 (ga.State.Width - 1) && between ny 0 (ga.State.Height - 1) then
Some (nx + ny*ga.State.Width)
else
None
module Game =
let culture = CultureInfo.InvariantCulture
let uiCulture = CultureInfo "en-US"
let init w h r =
// let rnd = Random.Shared
let rnd = Random 1974031
let cells = Array.init (w*h) (fun _ -> Covered (Empty, rnd.NextDouble() < r))
{
Width = w
Height = h
Cells = cells
}
|> Playing
type GameContent(creator : float -> GameState) =
class
inherit Controls.Control()
let gameState = creator 0.1
let typeface = Typeface "Segoe UI"
let mutable mousePos = Point()
let brush r g b =
let c = Color.FromRgb (byte r, byte g, byte b)
let b = SolidColorBrush c
b.Freeze ()
b
let rebeccaPurple = brush 0x66 0x33 0x99
let gray1px = Pen(Brushes.Gray, 1.)
let formatText brush sz text =
let ft = FormattedText(
text
, Game.uiCulture
, FlowDirection.LeftToRight
, typeface
, sz
, brush
, 1.
)
ft
let drawFormattedText (ctx : DrawingContext) ft x y =
ctx.DrawText (ft, Point (x, y))
let drawText (ctx : DrawingContext) brush sz text x y =
let ft = formatText brush sz text
drawFormattedText ctx ft x y
let computeGameArea (x : Controls.Control) (ps : PlayState) : GameArea =
let p0 = x.PointToScreen (Point (0., 0.))
let p1 = x.PointToScreen (Point (100., 100.))
let dpi = 0.01*(p1-p0)
let aw = x.ActualWidth*dpi.X
let ah = x.ActualHeight*dpi.Y
let ar = aw/ah
let pw = float ps.Width
let ph = float ps.Height
let pr = pw/ph
let gl, gt, cd, gw, gh =
if pr < ar then
let cd = floor (ah/ph)
let gw = cd*pw
let gh = cd*ph
let gl = floor ((aw-gw)*0.5)
let gt = floor ((ah-gh)*0.5)
gl, gt, cd, gw, gh
else
let cd = floor (aw/pw)
let gw = cd*pw
let gh = cd*ph
let gl = floor ((aw-gw)*0.5)
let gt = floor ((ah-gh)*0.5)
gl, gt, cd, gw, gh
let gr = gl+cd*pw
let gb = gt+cd*ph
{
State = ps
Left = gl
Top = gt
Right = gr
Bottom = gb
Width = gw
Height = gh
Dim = cd
DpiX = dpi.X
DpiY = dpi.Y
}
override x.OnMouseLeftButtonUp e =
let (Playing ps) = gameState
let gameArea = computeGameArea x ps
let mp = e.GetPosition x
match gameArea.QueryIndexFromCellPos (mp.X*gameArea.DpiX) (mp.Y*gameArea.DpiY) with
| None -> ()
| Some i ->
let c = ps.Cells.[i]
match c with
| Covered (cs, b) ->
match cs with
| Bomb -> ()
| _ -> ps.Cells.[i] <- Uncovering b
| _ -> ()
override x.OnMouseRightButtonUp e =
let (Playing ps) = gameState
let gameArea = computeGameArea x ps
let mp = e.GetPosition x
match gameArea.QueryIndexFromCellPos (mp.X*gameArea.DpiX) (mp.Y*gameArea.DpiY) with
| None -> ()
| Some i ->
let c = ps.Cells.[i]
match c with
| Covered (cs, b) ->
let ncs =
match cs with
| Empty -> Flag
| Flag -> Bomb
| Bomb -> Empty
ps.Cells.[i] <- Covered (ncs, b)
| _ -> ()
override x.OnMouseMove e =
mousePos <- e.GetPosition x
member x.OnGameTick e =
let (Playing ps) = gameState
let cs = ps.Cells
let ncs = Array.copy cs
for i = 0 to cs.Length - 1 do
let c = cs.[i]
let x,y = ps.CellPos i
match c with
| Uncovering b ->
if b then
ncs.[i] <- Exploding
else
let mutable n = 0
ps.VisitNeighbours x y (fun xx yy ii ->
let cc = ncs.[ii]
let nn =
match cc with
| Covered (_, true) -> 1
| Uncovering true -> 1
| Exploding -> 1
| Exploded -> 1
| _ -> 0
n <- n + nn
)
ncs.[i] <- Uncovered n
if n = 0 then
ps.VisitNeighbours x y (fun xx yy ii ->
let cc = ncs.[ii]
ncs.[ii] <-
match cc with
| Covered (_, b) -> Uncovering b
| _ -> cc
)
| Exploding ->
ps.VisitNeighbours x y (fun xx yy ii ->
let cc = ncs.[ii]
ncs.[ii] <-
match cc with
| Exploded -> cc
| _ -> Exploding
)
| _ -> ()
for i = 0 to cs.Length - 1 do
let c = cs.[i]
let nc = ncs.[i]
match (c, nc) with
| Uncovering _, Uncovering _ ->
failwith "what?"
| _ -> ()
Array.Copy (ncs, ps.Cells, ncs.Length)
x.InvalidateVisual ()
override x.OnRender ctx =
let (Playing ps) = gameState
let gameArea = computeGameArea x ps
let mp = Point(mousePos.X*gameArea.DpiX, mousePos.Y*gameArea.DpiY)
let dpiScale = ScaleTransform (1./gameArea.DpiX, 1./gameArea.DpiY)
ctx.PushTransform dpiScale
for x in 1..(ps.Width - 1) do
let xx = gameArea.Left+float x*gameArea.Dim
ctx.DrawLine (gray1px, Point(xx, gameArea.Top), Point(xx, gameArea.Bottom))
for y in 1..(ps.Height - 1) do
let yy = gameArea.Top+float y*gameArea.Dim
ctx.DrawLine (gray1px, Point(gameArea.Left, yy), Point(gameArea.Right, yy))
let hcd = 0.5*gameArea.Dim
for i = 0 to ps.Cells.Length - 1 do
let c = ps.Cells.[i]
let x, y = gameArea.CellPosFromIndex i
let cp = Point (x+hcd,y+hcd)
let fp = cp-Vector(8., 20.)
let bw = 3.
let ax, ay= x+bw,y+bw
let acd = gameArea.Dim-2.*bw
match c with
| Covered (cs, b) ->
ctx.DrawRectangle (rebeccaPurple, null, Rect(ax, ay, acd, acd))
match cs with
| Empty -> ()
| Flag -> ctx.DrawEllipse (Brushes.Cyan, null, cp, hcd*0.5, hcd*0.5)
| Bomb -> ctx.DrawEllipse (Brushes.Red, null, cp, hcd*0.5, hcd*0.5)
| Uncovering _ ->
ctx.DrawRectangle (Brushes.White, null, Rect(ax, ay, acd, acd))
| Uncovered cnt ->
if cnt > 0 then
drawText ctx Brushes.Cyan 32 $"{cnt}" fp.X fp.Y
| Exploding|Exploded ->
ctx.DrawRectangle (Brushes.Red, null, Rect(ax, ay, acd, acd))
let bombs =
ps.Cells
|> Array.map (fun c ->
match c with
| Covered (_,true) -> 1
| _ -> 0
)
|> Array.sum
let covered =
ps.Cells
|> Array.map (fun c ->
match c with
| Covered (_,_) -> 1
| _ -> 0
)
|> Array.sum
drawText ctx Brushes.LimeGreen 48. $"Bombs: {bombs}\nCells to uncover {covered-bombs}" 0. 0.
ctx.DrawEllipse (Brushes.LimeGreen, null, mp, 3., 3.)
ctx.Pop () // PushTransform
base.OnRender ctx
end
[<EntryPoint>]
[<STAThread>]
let main args =
try
CultureInfo.CurrentCulture <- Game.culture
CultureInfo.DefaultThreadCurrentCulture <- Game.culture
CultureInfo.CurrentUICulture <- Game.uiCulture
CultureInfo.DefaultThreadCurrentUICulture <- Game.uiCulture
let content = GameContent (Game.init 10 10)
content.SnapsToDevicePixels <- true
let dt = DispatcherTimer ()
dt.Interval <- TimeSpan.FromMilliseconds 100.
dt.Tick.Add content.OnGameTick
let w = Window()
w.Background <- Brushes.Black
w.Content <- content
w.WindowStartupLocation <- WindowStartupLocation.CenterScreen
w.SnapsToDevicePixels <- true
dt.IsEnabled <- true
let r = w.ShowDialog ()
0
with
| e ->
9
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment