F# Bombs away

bombs.fs

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