FCards - On the Web

namespace Solitaire.Website

open System
open System.Net.Http
open Microsoft.AspNetCore.Components.WebAssembly.Hosting
open Microsoft.Extensions.DependencyInjection

module Program =

  [<EntryPoint>]
  let Main args =
    let builder = WebAssemblyHostBuilder.CreateDefault(args)
    builder.Services.AddScoped<HttpClient>(
      fun _ -> new HttpClient(BaseAddress = Uri builder.HostEnvironment.BaseAddress)
      ) 
      |> ignore
    builder.RootComponents.Add<Main.MyApp>("#main")
    builder.Build().RunAsync() |> ignore
    0

module Solitaire.Website.Main

open Elmish
open Bolero
open Bolero.Html
open Cards
open Solitaire.Model
open Solitaire.Website.Update
open Solitaire.Website.Views


type MyApp() =
  inherit ProgramComponent<WebGame, WebCommands>()

  override this.Program =
    Program.mkSimple initialise update viewMain

module Solitaire.Website.Views

open Bolero
open Bolero.Html
open Cards
open Solitaire.Model
open Solitaire.Website.Update

let suits = [SYMBOL_HEART; SYMBOL_DIAMOND; SYMBOL_CLUB; SYMBOL_SPADE]

let wrap = List.singleton  // shortcut to wrap a thing in a list

type CardDisplay = {
  card: Card
  isFaceUp: bool
  isSelected: bool
  selection: CardSelection
}

let viewCardBack = span [ ] [ text "[###]"] 

let viewCard dispatch cardDisplay =
  match cardDisplay with 
  | { CardDisplay.isFaceUp=false } -> viewCardBack
  | { card=card; isSelected=isSelected; selection=selection } -> 
    let txt = text $"[{card}]"
    let colorAttr = 
      match card with 
      | IsRed _ -> ["red"]
      | IsBlack _ -> ["black"]
      | _ -> []
    let selectionAttr = if isSelected then ["selected"] else []
    let classAttr = colorAttr @ selectionAttr |> Attr.Classes
    span [ classAttr; on.click( fun _ -> selection |> SelectCard |> dispatch ) ] [txt]

let viewStacks dispatch webgame =
  webgame.game.stacks
  |> List.mapi (fun stacknum stack -> 
    stack
    |> List.mapi ( fun cardnum card -> 
        let location={stacknum=stacknum+1; cardnum=cardnum}
        { 
          card=card.card
          isFaceUp=card.isFaceUp
          isSelected=(webgame.selectedCard=StackCardSelected location)
          selection=StackCardSelected location
        }
        |> viewCard dispatch
    )
    |> fun cards -> cards @ [ span [ Classes ["dropTarget"]; on.click(fun _ -> StackTarget (stacknum + 1) |> PlaceCard |> dispatch ) ] [ text "[___]" ]  ]
    |> List.map ( fun x -> x |> wrap |> li [] )
    |> ul []
    |> fun x -> [h4 [] [(stacknum + 1).ToString() |> text]; x]
    |> div []
  )
  |> div [ Attr.Classes ["stacks"] ]

let viewAces dispatch webgame =
  webgame.game.aces
  |> List.mapi (fun stacknum stack -> 
    stack
    |> List.map ( fun card -> 
        {
          card=card
          isFaceUp=true
          isSelected=false
          selection=NoSelection
        } 
        |> viewCard dispatch
    )
    |> fun cards -> cards @ [ a [ Classes ["dropTarget"]; on.click(fun _ -> AceTarget (stacknum + 1) |> PlaceCard |> dispatch ) ] [ text "[___]" ]  ]
    |> List.map ( fun x -> x |> wrap |> li [] )
    |> ul []
    |> fun x -> [h4 [] [suits[stacknum] |> text]; x]
    |> div []
  )
  |> div [ Attr.Classes ["aces"] ]

let viewTable dispatch webgame =
  match webgame.game.table with 
    | [] -> []
    | [card] -> 
        [
          {
            card=card
            isFaceUp=true
            isSelected=(webgame.selectedCard=TableCardSelected)
            selection=NoSelection
          } 
          |> viewCard dispatch
        ]
    | topcard::rest -> 
        let facedowns = 
          rest
          |> List.map (fun card -> 
            {
              card=card
              isFaceUp=false
              isSelected=false
              selection=NoSelection
            }
            |> viewCard dispatch
          )
        let faceup = 
          {
            card=topcard
            isFaceUp=true
            isSelected=(webgame.selectedCard=TableCardSelected)
            selection=TableCardSelected
          }
          |> viewCard dispatch
        facedowns @ [ faceup ]
  |> List.map ( fun a -> li [] [a])
  |> ul []
  |> fun a -> [ h3 [] [text "Table"]; a]
  |> div [ Attr.Classes ["table"] ]

let viewDeck dispatch webgame =
  List.init webgame.game.deck.Length ( fun _ -> viewCardBack |> wrap |> li [] )
  |> ul [ on.click( fun _ -> DrawCards |> dispatch  ) ]
  |> fun a -> [ h3 [] [text "Deck"]; a]
  |> div [ Attr.Classes ["deck"] ]

let viewMain webgame dispatch = 
  let stacks = viewStacks dispatch webgame
  let aces = viewAces dispatch webgame
  let table = viewTable dispatch webgame
  let deck = viewDeck dispatch webgame
  let topHalf = div [Attr.Classes ["topHalf"]] [stacks; aces]
  let mode = 
    match webgame.selectedCard with 
    | NoSelection -> "mode_unselected"
    | _ -> "mode_selected" 
  div [Attr.Classes ["game"; mode]] [topHalf; table; deck]

module Solitaire.Website.Update
open Cards
open Solitaire.Model
open Solitaire.Actions

type StackCardLocation = {
  stacknum: int;
  cardnum: int;
}

type CardSelection =
  | NoSelection
  | TableCardSelected
  | StackCardSelected of StackCardLocation

type TargetSelection = 
  | StackTarget of int
  | AceTarget of int

type WebCommands =  // must be a DU
  | SelectCard of CardSelection
  | PlaceCard of TargetSelection
  | DrawCards

type WebGame = {
  selectedCard: CardSelection
  game: Game
}


let initialise args = 
  newDeck 
  |> shuffle 
  |> deal
  |> fun x -> {game = x; selectedCard = NoSelection}

  
let update message webgame =
  printfn "%A" message
  match message with
  | DrawCards -> 
      {webgame with 
        game = applyCommand Solitaire.Actions.DrawCards webgame.game
        selectedCard = NoSelection
      }
  | SelectCard selection -> 
      {webgame with selectedCard = selection}
  | PlaceCard target -> 
      match target, webgame.selectedCard with 
      | _, NoSelection -> webgame
      | AceTarget _, TableCardSelected ->
          {webgame with 
            game = applyCommand TableToAce webgame.game
            selectedCard = NoSelection 
          }
      | AceTarget _, StackCardSelected selection -> 
          {webgame with 
            game = applyCommand (StackToAce selection.stacknum) webgame.game
            selectedCard = NoSelection 
          } 
      | StackTarget toStack, TableCardSelected ->       
          {webgame with 
            game = applyCommand (TableToStack toStack) webgame.game
            selectedCard = NoSelection 
          } 
      | StackTarget toStack, StackCardSelected selection ->       
          {webgame with 
            game = 
              applyCommand (
                {
                  sourceStack=selection.stacknum
                  numCards=(webgame.game.stacks[selection.stacknum-1].Length - selection.cardnum) 
                  targetStack=toStack
                }
                |> MoveCards
              ) webgame.game
            selectedCard = NoSelection 
          }