clp/train-track-game
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

first commit

Browse source 
It doesn't really work as a game.
This commit is contained in:
Christian Lawson-Perfect 2025-02-09 20:09:57 +00:00
commit 1916afcb03
12 changed files with 7797 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

3
.gitignore vendored Normal file
View file

@ -0,0 +1,3 @@
.make.*
elm-stuff/
error.txt

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)"

7145
app.js Normal file
View file

File diff suppressed because it is too large Load diff

28
elm.json Normal file
View file

@ -0,0 +1,28 @@
{
"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/random": "1.0.0",
"elm/svg": "1.0.1",
"elm-community/list-extra": "8.7.0",
"elm-community/random-extra": "3.2.0"
},
"indirect": {
"elm/json": "1.1.3",
"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);

439
src/App.elm Normal file
View file

@ -0,0 +1,439 @@
module App exposing (..)
import Browser
import ConstraintLayout as CL
import Html as H exposing (Html)
import Html.Attributes as HA
import Html.Events as HE
import List.Extra as LE
import Random as R
import Random.Extra as RE
import Random.List as RL
import Svg exposing (Svg)
import Svg.Attributes as SA
import Svg.Events as SE
import Tuple exposing (first, second, pair)
import Vector exposing (..)
type alias Value = Int
type alias Id = Int
type alias JunctionFunction = Value -> List Value -> List Value
type alias Junction =
{ id : Id
, fn : JunctionFunction
, label : String
, next : List Id
, stack : List Value
, position : Vector
, solution_stack : List Value
}
type alias Model =
{ junctions : List Junction
, selected_junction : Maybe Id
}
type Msg
= Move (Id, Id)
| SetJunctions (List Junction)
| ClickJunction Id
| RandomMove
lerp : Float -> Float -> Float -> Float
lerp a b t = t*b + (1-t)*a
is_id : Id -> { a | id : Id } -> Bool
is_id id = .id >> (==) id
get_junction : List Junction -> Id -> Maybe Junction
get_junction junctions id = junctions |> LE.find (is_id id)
set_junction : Id -> Junction -> List Junction -> List Junction
set_junction id j junctions = LE.setIf (is_id id) j junctions
iterate : (a -> a) -> Int -> a -> a
iterate fn n a =
if n > 0 then
iterate fn (n-1) (fn a)
else
a
layout_junctions : Model -> Model
layout_junctions model =
let
gap = 100
min_dist_constraints =
List.range 0 (List.length model.junctions)
|> LE.uniquePairs
|> List.map (\(a,b) -> (CL.MinDistance gap, a, b))
max_dist_constraints =
model.junctions
|> List.concatMap (\j -> List.map (\i -> (CL.MaxDistance (gap), j.id, i)) j.next)
same_y_constraints =
model.junctions
|> List.concatMap (\j -> List.map (\i -> (CL.SameY, j.id, i)) j.next)
below_constraints =
model.junctions
|> List.concatMap (\j -> List.map2 (\i k -> (CL.Below (gap/2), i, k)) j.next (List.drop 1 j.next))
right_of_constraints =
model.junctions
|> List.concatMap (\j -> List.map (\i -> (CL.RightOf gap, j.id, i)) j.next)
constraints =
[(CL.FixedPosition (0,0),0,0)]
++ min_dist_constraints
++ max_dist_constraints
++ right_of_constraints
-- ++ below_constraints
++ same_y_constraints
new_positions =
model.junctions
|> List.map .position
|> iterate (CL.layout constraints) 1000
junctions = List.map2
(\j p -> { j | position = p })
model.junctions
new_positions
in
{ model | junctions = junctions }
path_through_points : List Vector -> String
path_through_points points =
points
|> List.indexedMap (\i (x,y) -> (if i==0 then "M" else "L")++" "++(ff x)++" "++(ff y))
|> String.join " "
bezier_curve : Vector -> Vector -> Vector -> Vector -> String
bezier_curve (x1,y1) (x2,y2) (x3,y3) (x4,y4) =
"M "++(ff x1)++" "++(ff y1)++" C "++(ff x2)++" "++(ff y2)++" "++(ff x3)++" "++(ff y3)++" "++(ff x4)++" "++(ff y4)
translate_to : Vector -> String
translate_to (x,y) = "translate("++(ff x)++","++(ff y)++")"
main = Browser.document
{ init = init
, update = update
, subscriptions = subscriptions
, view = view
}
blank_junction : Junction
blank_junction =
{ id = 0
, fn = add_to_end
, label = ""
, stack = []
, position = (0,0)
, next = []
, solution_stack = []
}
add_to_end a list = list++[a]
add_junction_links : Junction -> Id -> List Id -> Junction
add_junction_links j id next = { j | id = id, next = next }
source_junction stack = { blank_junction | stack = stack, label="S" } |> add_junction_links
empty_junction = blank_junction |> add_junction_links
final_junction = add_junction_links { blank_junction | label = "F" }
unary_junction fn label = { blank_junction | fn = fn >> add_to_end, label = label } |> add_junction_links
random_junctions : R.Generator (List Junction)
random_junctions =
let
sources : R.Generator (List Junction)
sources =
R.int 1 2 |> R.andThen (\n -> R.list n (R.int 1 3 |> R.andThen (\m -> R.list m (R.int 1 9) |> R.map (source_junction))))
|> R.map (List.indexedMap (\i j -> j i []))
add_op = R.int -4 5 |> R.map (\x -> if x<=0 then x-1 else x) |> R.map (\x -> unary_junction ((+) x) (if x > 0 then "+"++(fi x) else fi x))
other_ops =
[ R.int 2 5 |> R.map (\x -> unary_junction ((*) x) ("×"++(fi x)))
]
ops : R.Generator (List (Int -> List Id -> Junction))
ops = R.int 1 4 |> R.andThen (\n -> R.list n (R.uniform add_op other_ops |> R.andThen identity))
finals = R.int 1 1 |> R.andThen (\n -> R.list n (R.constant final_junction))
step : (List Junction, List Junction, List (Int -> List Id -> Junction)) -> R.Generator (List Junction, List Junction)
step (last, prev, next) =
let
q = Debug.log "join" (List.map .label prev, List.map .label id_next)
maxid = List.maximum (List.map .id prev) |> Maybe.withDefault -1
-- add IDs to the next junctions
id_next : List Junction
id_next =
next
|> List.indexedMap (\i j -> j (i+maxid+1) [])
add_track : List Junction -> List Junction -> R.Generator (List (Id,Id))
add_track ps ns = case (ps,ns) of
(p::prest, n::nrest) -> (add_track prest nrest) |> R.map ((::) (p.id,n.id))
(p::prest, []) ->
case id_next of
n1::nrest -> R.uniform n1 nrest |> R.map2 (\r n -> (p.id, n.id)::r) (add_track prest [])
[] -> R.constant []
([], n::nrest) ->
case prev of
p1::prest -> R.uniform p1 prest |> R.map2 (\r p -> (p.id, n.id)::r) (add_track [] nrest)
[] -> R.constant []
([], []) -> R.constant []
tracks = add_track prev id_next
add_joins : Junction -> R.Generator Junction
add_joins j =
tracks
|> R.map (List.filter (first >> (==) j.id) >> List.map second)
|> R.map (\n -> { j | next = n })
joined_prev : R.Generator (List Junction)
joined_prev = RE.sequence (List.map add_joins prev)
in
R.map (\p -> (last++p, id_next))
joined_prev
add_level : R.Generator (List (Int -> List Id -> Junction)) -> R.Generator (List Junction, List Junction) -> R.Generator (List Junction, List Junction)
add_level rnext rlastprev =
R.map2 (\next (last,prev) -> step (last, prev, next))
rnext
rlastprev
|> R.andThen identity
in
List.foldl add_level (R.map (pair []) sources) ((List.repeat 3 ops)++[finals])
|> R.map (\(a,b) -> a++b)
random_position = R.map2 pair (R.float 0 1) (R.float 0 1)
scatter_junctions : List Junction -> R.Generator (List Junction)
scatter_junctions junctions =
R.list (List.length junctions) random_position
|> R.map (List.map2 (\j p -> { j | position = p}) junctions)
available_moves : List Junction -> List (Id,Id)
available_moves junctions =
junctions
|> List.filter (.stack >> List.length >> (<) 0)
|> List.concatMap (\j -> List.map (pair j.id) j.next)
random_solution : List Junction -> R.Generator (List Junction)
random_solution junctions =
let
step : List Junction -> R.Generator (List Junction)
step js = case available_moves js of
[] -> R.constant js
a::rest ->
R.uniform a rest
|> R.andThen (\move -> step (move_item move js))
in
(step junctions)
|> R.map (List.map .stack)
|> R.map (List.map2 (\j s -> { j | solution_stack = s }) junctions)
{- ------------------- -}
init_model =
{ junctions =
[ source_junction [1,2,3,4,5,6] 0 [1,3]
, unary_junction ((*) 2) "×2" 1 [2]
, unary_junction (\x -> x - 1) "-1" 2 [4]
, unary_junction ((+) 1) "+1" 3 [2,4,5]
, final_junction 4 []
, final_junction 5 []
]
, selected_junction = Nothing
}
init : () -> (Model, Cmd Msg)
init _ =
( init_model
, Cmd.batch
[ R.generate (SetJunctions) (random_junctions |> R.andThen scatter_junctions |> R.andThen random_solution)
]
)
nocmd model = (model, Cmd.none)
maybeFilter : (a -> Bool) -> Maybe a -> Maybe a
maybeFilter predicate = Maybe.andThen (\a -> if predicate a then Just a else Nothing)
update : Msg -> Model -> (Model, Cmd Msg)
update msg model = case msg of
Move (from,to) -> { model | junctions = move_item (from,to) model.junctions } |> nocmd
SetJunctions junctions -> { model | junctions = junctions } |> layout_junctions |> nocmd
ClickJunction id ->
model.selected_junction
|> Maybe.andThen (get_junction model.junctions >> maybeFilter (.next >> List.member id))
|> Maybe.map (\j -> { model | junctions = move_item (j.id, id) model.junctions })
|> Maybe.withDefault model
|> (\m -> { m | selected_junction = Just id })
|> nocmd
RandomMove -> case available_moves model.junctions of
m::rest -> (model, R.generate Move (R.uniform m rest))
[] -> model |> nocmd
move_item : (Id,Id) -> List Junction -> List Junction
move_item (from,to) junctions = case (get_junction junctions from, get_junction junctions to) of
(Just jfrom, Just jto) -> case jfrom.stack of
v::rest ->
let
nfrom = { jfrom | stack = rest }
nto = { jto | stack = jto.fn v jto.stack }
in
junctions
|> (set_junction from nfrom)
|> (set_junction to nto)
_ -> junctions
_ -> junctions
subscriptions model = Sub.none
fi = String.fromInt
ff = String.fromFloat
tf = toFloat
view : Model -> Browser.Document Msg
view model =
let
positions = List.map .position model.junctions
minx = positions |> List.map first |> List.minimum |> Maybe.withDefault 0
maxx = positions |> List.map first |> List.maximum |> Maybe.withDefault 0
miny = positions |> List.map second |> List.minimum |> Maybe.withDefault 0
maxy = positions |> List.map second |> List.maximum |> Maybe.withDefault 0
margin = 100
viewbox = (ff <| minx-margin)++" "++(ff <| miny-margin)++" "++(ff <| maxx-minx + 2*margin)++" "++(ff <| (maxy-miny + 2*margin))
view_junction junction =
let
(x,y) = junction.position
can_move_to =
model.selected_junction
|> Maybe.andThen (get_junction model.junctions)
|> Maybe.map (.next >> List.member junction.id)
|> Maybe.withDefault False
selected = model.selected_junction == Just junction.id
view_stack_item in_solution i n =
let
path = (junction.id, i)
selected_item = (not in_solution) && (model.selected_junction == Just junction.id) && i == 0
in
Svg.g
[ SA.transform <| translate_to (0,(tf i)*11 + 18)
]
[ Svg.circle
[ SA.r "5"
, SA.fill (if in_solution then "lightgray" else if selected_item then "yellow" else "lightblue")
]
[]
, Svg.text_
[ SA.textAnchor "middle"
, SA.dominantBaseline "middle"
, SA.fontSize "5"
]
[ Svg.text <| fi n
]
]
in
Svg.g
[ SA.transform <| translate_to junction.position ]
[ Svg.g
[ SE.onClick (ClickJunction junction.id) ]
[ Svg.circle
[ SA.r "10"
, SA.fill (if selected then "pink" else if can_move_to then "lightgreen" else "grey")
, SA.stroke "black"
]
[]
, Svg.text_
[ SA.fontSize "10"
, SA.textAnchor "middle"
, SA.dominantBaseline "middle"
]
[ Svg.text junction.label ]
]
, Svg.g
[]
(List.indexedMap (view_stack_item True) junction.solution_stack)
, Svg.g
[]
(List.indexedMap (view_stack_item False) junction.stack)
]
junctions_by_y =
model.junctions
|> List.sortBy (.position >> second)
tracks =
junctions_by_y
|> List.concatMap (\j -> j.next |> List.map (get_junction model.junctions >> Maybe.map (\j2 -> (j.position, j2.position))) )
|> List.filterMap identity
num_tracks = List.length tracks
view_track i ((x1,y1),(x2,y2)) =
let
yo = (tf i) / (tf num_tracks) * 10 - 5
in
Svg.path
[ SA.d <| bezier_curve (x1,y1) (lerp x1 x2 0.5,y1) (lerp x1 x2 0.5,y2) (x2,y2)
, SA.fill "none"
, SA.stroke "black"
, SA.strokeDasharray "2 2"
]
[]
in
{
title = "Hey",
body =
[ Svg.svg
[ HA.attribute "viewBox" viewbox
]
[ Svg.g
[]
(List.indexedMap view_track tracks)
, Svg.g
[]
(List.map view_junction model.junctions)
]
, H.p
[]
[ H.button [ HE.onClick RandomMove] [H.text "Random move"]]
, H.pre [] [H.text <| Debug.toString <| available_moves model.junctions ]
]
}

72
src/ConstraintLayout.elm Normal file
View file

@ -0,0 +1,72 @@
module ConstraintLayout exposing (layout, satisfy, Constraint, ConstraintKind(..))
import List.Extra as LE
import Tuple exposing (first, second)
import Vector exposing (..)
type alias Index = Int
type alias Constraint = (ConstraintKind, Index, Index)
type ConstraintKind
= MinDistance Float
| MaxDistance Float
| RightOf Float
| Below Float
| FixedPosition Vector
| SameY
satisfy : List Vector -> Constraint -> List (Index,Vector)
satisfy positions (constraint,ia,ib) =
case (LE.getAt ia positions, LE.getAt ib positions) of
(Just a, Just b) ->
case constraint of
MinDistance mind ->
let
d = distance a b
n = sub b a |> normalise
f = max 0 ((mind-d)/2)
m = smul f n
in
[ (ia, neg m)
, (ib, m)
]
FixedPosition p -> [ (ia, sub p a)]
RightOf d->
let
dx = (first a) - ((first b) - d)
f = max 0 dx/2
in
[ (ia, (-f,0))
, (ib, (f,0))
]
Below d->
let
dy = (first a) - ((first b) - d)
f = max 0 dy/2
in
[ (ia, (0,-f))
, (ib, (0,f))
]
SameY ->
let
dy = (second b) - (second a)
in
[ (ia, (0, dy/10))
, (ib, (0,-dy/10))
]
_ -> []
_ -> []
layout : List Constraint -> List Vector -> List Vector
layout constraints positions =
let
f = 0.1
changes = List.concatMap (satisfy positions) constraints
in
List.foldl (\(i,v) -> LE.updateAt i (add (smul f v))) positions changes

43
src/Vector.elm Normal file
View file

@ -0,0 +1,43 @@
module Vector exposing (..)
import Tuple exposing (pair, first, second)
type alias Vector = (Float, Float)
type alias LineSegment = (Vector, Vector)
add (x1,y1) (x2,y2) = (x1+x2, y1+y2)
sub (x1,y1) (x2,y2) = (x1-x2, y1-y2)
len (x,y) = sqrt (x*x + y*y)
smul s (x,y) = (s*x, s*y)
neg (x,y) = (-x,-y)
distance v1 v2 = sub v1 v2 |> len
midpoint (x1,y1) (x2,y2) = ((x1+x2)/2, (y1+y2)/2)
normalise (x,y) =
let
d = len (x,y)
in
(x/d, y/d)
normal (x,y) = normalise (-y,x)
dot (x1,y1) (x2,y2) = x1*x2 + y1*y2
sum : List Vector -> Vector
sum = List.foldl add (0,0)
point_line_distance p (p1,p2) =
let
v1 = sub p2 p1
v2 = sub p p1
n = normal v1
d1 = len v1
alpha = (dot v1 v2) / d1
d = len (sub p (add p1 (smul alpha v1)))
in
if alpha<0 then len (sub p p1) else if alpha>d1 then len (sub p p2) else d
closest : (a -> Vector) -> Vector -> List a -> Maybe (Int, Float, a)
closest get_position p1 = List.map (\a -> (a, get_position a |> sub p1 |> len)) >> List.indexedMap (\i (a,d) -> (i,d,a)) >> List.sortBy (\(i,d,a) -> d) >> List.head

0
style.css Normal file
View file