clp/dig-a-hole-game
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

first commit

Browse source
This commit is contained in:
Christian Lawson-Perfect 2025-02-09 20:13:36 +00:00
commit 94c58e7f74
11 changed files with 604 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

4
.gitignore vendored Normal file
View file

@ -0,0 +1,4 @@
.make.*
elm-stuff/
error.txt
app.js

2
.watchmakerc Normal file
View file

@ -0,0 +1,2 @@
extensions:
- .elm

11
Makefile Normal file
View file

@ -0,0 +1,11 @@
DIRNAME=$(notdir $(CURDIR))
ELMS=$(wildcard src/*.elm)
app.js: src/App.elm $(ELMS)
-elm make $< --output=$@ 2> error.txt
@cat error.txt
upload: app.js index.html style.css
rsync -avz . clpland:~/domains/somethingorotherwhatever.com/html/$(DIRNAME)
@echo "Uploaded to https://somethingorotherwhatever.com/$(DIRNAME)"

10
TODO Normal file
View file

@ -0,0 +1,10 @@
* Draw outlines around the cells based on their depth, so it's easier to see how deep they are.
* Add something like a "mining machine" which must be at level 0, and makes a path of steps of 1 height.
The aim is to have a way of getting money once you're stuck, and to give an incentive to not dig some cells.
* An expensive "just dig this cell no matter what" tool?
* Add a popup thing each time you make a move, showing how much money you dug up or spent.
* Different kinds of treasure, to make it interesting.

25
elm.json Normal file
View file

@ -0,0 +1,25 @@
{
"type": "application",
"source-directories": [
"src"
],
"elm-version": "0.19.1",
"dependencies": {
"direct": {
"elm/browser": "1.0.2",
"elm/core": "1.0.5",
"elm/html": "1.0.0",
"elm/json": "1.1.3",
"elm/random": "1.0.0"
},
"indirect": {
"elm/time": "1.0.0",
"elm/url": "1.0.0",
"elm/virtual-dom": "1.0.3"
}
},
"test-dependencies": {
"direct": {},
"indirect": {}
}
}

23
index.html Normal file
View file

@ -0,0 +1,23 @@
<!DOCTYPE HTML>
<html>
<head>
<meta charset="UTF-8">
<meta name="viewport" content="width=device-width,initial-scale=1.0">
<title>Elm app by clp</title>
<link rel="stylesheet" href="style.css">
</head>
<body>
<header>
<h1>Elm app by clp</h1>
</header>
<main>
<p>This is an app which will either load succesfully, and you'll wonder whether you saw this text at all, or fail ignominiously, showing you only this text.</p>
<p>On balance of probabilities: I'm sorry I couldn't be bothered to make this work for you.</p>
</main>
<footer>Made by <a href="https://somethingorotherwhatever.com">clp</a></footer>
<script src="app.js"></script>
<script src="load-app.js" type="module"></script>
</body>
</html>

10
load-app.js Normal file
View file

@ -0,0 +1,10 @@
import show_error from './show-error.mjs';
async function init_app() {
const compilation_error = await show_error;
if(compilation_error) {
return;
}
const app = Elm.App.init({node: document.body, flags: {}});
}
init_app();

21
show-error.mjs Normal file
View file

@ -0,0 +1,21 @@
export default fetch('/error.txt').then(r=>{
if(r.ok) {
return r.text();
} else {
throw('');
}
}).then(text => {
if(!text) {
return false;
}
document.body.innerHTML = '';
const error_show = document.createElement('pre');
error_show.setAttribute('id','build-error');
error_show.style.background = 'black';
error_show.style.color = 'white';
error_show.style.padding = '1em';
error_show.style['font-size'] = '16px';
error_show.textContent = text;
document.body.appendChild(error_show);
return true;
}).catch(e => false);

331
src/App.elm Normal file
View file

@ -0,0 +1,331 @@
module App exposing (..)
import Array exposing (Array)
import Browser
import Browser.Events
import Grid exposing (Coords)
import Html as H exposing (Html)
import Html.Attributes as HA
import Html.Events as HE
import Json.Decode as JD
import Random
import Tuple exposing (pair, first, second)
dynamite_cost level = (level+1) * 5
money_for level =
Array.get level
(Array.fromList [0,5,10,20,50,75,100])
|> Maybe.withDefault (level * 50 - 200)
{- 4, 9, 16, 25 -}
{- 5, 10, 20, 50, 100 -}
main = Browser.document
{ init = init
, update = update
, subscriptions = subscriptions
, view = view
}
type Action
= Dig
| Fill
type Rock
= Dirt
| Boulder
| Treasure
type alias Cell =
{ dug : Int
, rocks : Array (Rock, Bool)
}
cell_rock : Cell -> Rock
cell_rock cell = (Array.get cell.dug cell.rocks) |> Maybe.map first |> Maybe.withDefault Dirt
type alias Grid = Grid.Grid Cell
type alias Model =
{ grid : Grid
, money : Int
, action : Action
}
default_cell =
{ dug = 0
, rocks = (Array.repeat 10 (Dirt, False))
}
empty_grid : Grid
empty_grid = Grid.fill 5 5 default_cell
rock_probabilities =
[ (10, Boulder)
]
random_rock : Random.Generator (Rock, Bool)
random_rock =
Random.weighted
(100, Dirt)
rock_probabilities
|> Random.map (\r -> (r, False))
random_walk : Random.Generator (List Coords)
random_walk =
let
start = Random.map2 pair (Random.int 0 9) (Random.int 0 9)
step : Int -> (Random.Generator (List Coords)) -> (Random.Generator (List Coords))
step _ rlast =
rlast |> Random.andThen
(\last -> case last of
[] -> Random.map List.singleton start
(x,y)::others ->
let
choices = [(x-1,y),(x+1,y),(x,y-1),(x,y+1)] |> List.filter (\(x2,y2) -> x>=0 && x<10 && y>=0 && y<10)
in
Random.uniform (x,y) choices |> Random.map (\c -> c::last)
)
in
List.foldl
step
(Random.constant [])
(List.range 0 10)
random_grid : Random.Generator Grid
random_grid =
let
width = 7
height = 7
rcells =
Random.list
(width*height)
( Random.list 10 random_rock
|> Random.map (Array.fromList >> (\rocks -> { default_cell | rocks = rocks }))
)
|> Random.map Array.fromList
rgrid =
rcells
|> Random.map (\cells -> { width = width, height = height, cells = cells })
rwalks : Random.Generator (List (List Coords))
rwalks = Random.list 10 random_walk
apply_walk : List Coords -> Int -> Grid -> Grid
apply_walk walk start grid =
List.foldl
(\(z,pos) -> Grid.map_cell pos (\cell -> { cell | rocks = Array.set (z+start) (Treasure, False) cell.rocks}))
grid
(List.indexedMap pair walk)
in
Random.andThen
(\walks ->
List.foldl
(\walk -> Random.map2 (apply_walk walk) (Random.int 1 3))
rgrid
walks
)
rwalks
init_model : Model
init_model =
{ grid = empty_grid
, money = 0
, action = Dig
}
type Msg
= SelectCell Int Coords
| SetGrid Grid
| SetAction Action
| Noop
nocmd model = (model, Cmd.none)
init : () -> (Model, Cmd Msg)
init _ = (init_model, Random.generate SetGrid random_grid)
update msg model = case (Debug.log "msg" msg) of
SelectCell button coords -> click_cell button coords model |> nocmd
SetGrid grid -> { model | grid = Debug.log "grid" grid } |> nocmd
SetAction action -> { model | action = action } |> nocmd
Noop -> model |> nocmd
click_result : Coords -> Model -> Maybe (Cell, Int)
click_result coords model =
let
grid = model.grid
cell = Grid.get_cell coords grid |> Maybe.withDefault default_cell
neighbours = Grid.neighbours 1 coords model.grid
num_equal = neighbours |> List.filter (.dug >> (==) cell.dug) |> List.length
sum_diff = neighbours |> List.map (\c2 -> c2.dug - cell.dug) |> List.sum
all_greater = neighbours |> List.all (.dug >> (<) cell.dug)
rock = cell_rock cell
res : Maybe (Cell, Int)
res =
case (rock, model.action) of
(Treasure, Dig) -> Just ({ cell | rocks = Array.set cell.dug (Dirt,True) cell.rocks }, money_for cell.dug)
(Dirt, Dig) ->
if num_equal >= cell.dug + 1 || sum_diff > 2 || all_greater || cell.dug == 0 then
Just ({ cell | dug = cell.dug + 1 }, cell.dug)
else
Nothing
(Boulder, Dig) ->
Just ({ cell | rocks = Array.set cell.dug (Dirt, False) cell.rocks }, -(dynamite_cost cell.dug))
(_, Fill) ->
if cell.dug > 0 then
Just ({ cell | dug = cell.dug - 1 }, -(cell.dug-1))
else
Nothing
in
res |> Maybe.andThen (\(ncell, cost) -> if model.money + cost >= 0 then res else Nothing)
button_action button action = case button of
0 -> action
_ -> case action of
Dig -> Fill
_ -> Dig
click_cell button coords model =
case click_result coords { model | action = button_action button model.action } of
Nothing -> model
Just (ncell, money) ->
let
ngrid = Grid.set_cell coords ncell model.grid
in
{ model | grid = ngrid, money = model.money + money }
can_action_cell : Coords -> Model -> Bool
can_action_cell coords model = click_result coords model /= Nothing
total_score : Grid -> Int
total_score =
(.cells)
>> Array.toList
>> List.map (.dug)
>> List.sum
subscriptions model =
Browser.Events.onKeyDown
( JD.field "key" JD.string
|> JD.andThen (\key ->
case (String.toUpper key) of
"D" -> JD.succeed (SetAction Dig)
"F" -> JD.succeed (SetAction Fill)
_ -> JD.fail (Debug.log "bad" ("unrecognised key "++key))
)
)
radio : List (H.Attribute Msg) -> String -> Html Msg
radio attr label =
H.label
[]
[ H.input
(([ HA.type_ "radio"])++attr)
[]
, H.text label
]
view : Model -> Browser.Document Msg
view model =
let
grid = model.grid
view_cell : Coords -> Cell -> Html Msg
view_cell coords v =
let
(rock, flag) = Array.get v.dug v.rocks |> Maybe.withDefault (Dirt, False)
in
H.td
[ HA.classList
[ ("can-increment", can_action_cell coords model)
]
, HA.style "background" <| "hsl(60,50%,"++(String.fromFloat (50 / (toFloat (v.dug+1))))++"%)"
, HA.attribute "data-background" <| "hsl(60,50%,"++(String.fromFloat (50 / (toFloat (v.dug+1))))++")"
, HE.on "mousedown"
( JD.field "button" JD.int
|> JD.map (\button ->
let
z = Debug.log "button" button
in
SelectCell button coords
)
)
, HE.preventDefaultOn "contextmenu" <| JD.succeed (Noop, True)
]
[ H.div
[]
[ H.text <|
(
case rock of
Dirt -> " "
Boulder -> "🪨"
Treasure -> "🪙"
) ++ (
String.fromInt v.dug
) ++ (
if flag then "⚐" else " "
)
]
]
view_grid : Html Msg
view_grid =
H.table []
( List.range 0 (grid.height-1)
|> List.map
(\y ->
H.tr
[]
(List.range 0 (grid.width-1)
|> List.map
(\x ->
view_cell (x,y) (Grid.get_cell (x,y) grid |> Maybe.withDefault default_cell)
)
)
)
)
action_radio action label =
radio
[ HE.onClick <| SetAction action
, HA.value label
, HA.name "action"
, HA.checked <| model.action == action
]
label
in
{
title = "Hey",
body =
[ view_grid
, H.p
[]
[ H.text <| ("Score: "++(String.fromInt <| total_score model.grid))
]
, H.p
[]
[ H.text <| ("Money: £"++(String.fromInt <| model.money))
]
, H.fieldset
[ ]
[ H.legend
[]
[ H.text <| "Action: " ++ (Debug.toString model.action) ]
, action_radio Dig "Dig / Fill"
, action_radio Fill "Fill / Dig"
]
]
}

126
src/Grid.elm Normal file
View file

@ -0,0 +1,126 @@
module Grid exposing
(Grid,
Coords,
fromString,
fromCoords,
fill,
get_row,
set_cell,
get_cell,
map_cell,
coords,
connected_components,
neighbours,
neighbour_coords
)
import Array exposing (Array)
import Set
type alias Coords = (Int,Int)
type alias Grid x =
{ width: Int
, height: Int
, cells: Array x
}
fromCoords width height fn =
let
decide i =
let
x = modBy width i
y = (i - x) // width
in
fn (x,y)
in
Grid width height ((Array.fromList << List.map decide) (List.range 0 (width*height-1)))
fromString str parse_cell =
let
rows = (String.split "\n" (String.trim str))
height = List.length rows
width = Maybe.withDefault 0 (Maybe.map String.length (List.head rows))
cells = (String.join "" >> String.toList >> (List.map parse_cell) >> Array.fromList) rows
in
{ width = width
, height = height
, cells = cells
}
fill width height value =
{ width = width
, height = height
, cells = Array.repeat (width*height) value
}
get_row : Int -> Grid x -> Array x
get_row row grid = Array.slice (row*grid.width) ((row+1)*grid.width) grid.cells
set_cell : Coords -> x -> Grid x -> Grid x
set_cell (x,y) value grid =
let
i = y*grid.width + x
in
{ grid | cells = (Array.indexedMap (\j -> \c -> if j==i then value else c) grid.cells) }
get_cell : Coords -> Grid x -> Maybe x
get_cell (x,y) grid =
let
i = y*grid.width + x
in
if x>=0 && x<grid.width && y>=0 && y<grid.height then
Array.get i grid.cells
else
Nothing
coords grid = List.concatMap (\y -> List.map (\x -> (x,y)) (List.range 0 (grid.width-1))) (List.range 0 (grid.height-1))
map_cell : Coords -> (x -> x) -> Grid x -> Grid x
map_cell pos fn grid =
case get_cell pos grid of
Nothing -> grid
Just x -> set_cell pos (fn x) grid
connected_components : Bool -> (x -> Bool) -> Grid x -> List (List Coords)
connected_components allow_diagonals include grid =
let
init_components : Array (Maybe Int)
init_components = Array.indexedMap (\i -> \c -> if include c then Just i else Nothing) grid.cells
merge_components : y -> y -> Array y -> Array y
merge_components a b components = Array.map (\c -> if c==b then a else c) components
check_edge p1 p2 components =
let
g : Grid (Maybe Int)
g = Grid grid.width grid.height components
a = get_cell p1 g
b = get_cell p2 g
in
case (a,b) of
(Just (Just ja), Just (Just jb)) -> if ja /= jb then merge_components (Just ja) (Just jb) components else components
_ -> components
check_pos pos =
let
check p2 components = check_edge pos p2 components
(x,y) = pos
straights = check (x-1,y) >> check (x+1,y) >> check (x,y-1) >> check (x,y+1)
in
if allow_diagonals then
check (x-1,y-1) >> check (x-1,y+1) >> check (x+1,y+1) >> check (x-1,y+1) >> straights
else
straights
component_per_cell = (Array.toList << List.foldl check_pos init_components) (coords grid)
unique_components = (List.filterMap identity >> Set.fromList >> Set.toList) component_per_cell
final_components = List.map (\id -> List.filterMap identity <| List.map2 (\component -> \pos -> if component == Just id then Just pos else Nothing) component_per_cell (coords grid)) unique_components
in
final_components
{- Coords of cells at most d steps from given position, excluding that position -}
neighbour_coords : Int -> Coords -> List Coords
neighbour_coords d (x,y) = (List.concatMap (\dy -> List.map (\dx -> (x+dx,y+dy)) <| List.range -d d) (List.range -d d)) |> List.filter ((/=) (x,y))
{- Cells at most d steps from given position, excluding that position -}
neighbours : Int -> Coords -> Grid x -> List x
neighbours d pos grid = neighbour_coords d pos |> List.filterMap (\npos -> get_cell npos grid)

41
style.css Normal file
View file

@ -0,0 +1,41 @@
* {
box-sizing: border-box;
}
body {
margin: 0;
}
table {
border-collapse: collapse;
touch-action: manipulation;
user-select: none;
margin: 1em auto;
}
td {
background: green;
font-size: 6svw;
font-family: monospace;
text-align: center;
&.can-increment {
color: green;
cursor: pointer;
}
& div {
width: 2em;
height: 2em;
line-height: 2em;
border-radius: 50%;
background: white;
}
}
fieldset {
display: flex;
& label {
flex-grow: 1;
text-align: center;
}
}