Created
February 13, 2024 10:31
-
-
Save seanparsons/c0431e873c25a544170cdf3a80661622 to your computer and use it in GitHub Desktop.
Cypher System Tasks Experiment
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
normalPage : Html -> Text | |
normalPage page = | |
use Text ++ | |
"<!doctype html>" ++ html.toText page | |
name : Text -> Attribute | |
name = Attribute "name" | |
type TaskAttempt | |
= { difficulty : Nat, skills : Nat, assets : Nat, effort : Nat } | |
service.taskForm.doc = {{ Responds to "/" }} | |
service.taskForm : '{Route, Remote} () | |
service.taskForm = | |
do | |
use Attribute style | |
use html div input label text | |
Route.noCapture GET top | |
ok.html | |
(normalPage | |
(html.html | |
[] | |
[ html.head | |
[] | |
[ script | |
[src "https://unpkg.com/[email protected]/dist/htmx.min.js"] [] | |
, html.link | |
[ href | |
"https://cdn.jsdelivr.net/npm/[email protected]/dist/css/bootstrap.min.css" | |
, rel "stylesheet" | |
, Attribute | |
"integrity" | |
"sha384-T3c6CoIi6uLrA9TneNEoa7RxnatzjcDSCmG1MXxSR1GAsXEV/Dwwykc2MPK8M2HN" | |
, Attribute "crossorigin" "anonymous" | |
] | |
] | |
, html.body | |
[] | |
[ div | |
[ class "position-relative" | |
, style "width: 100%; height: 800px" | |
] | |
[ div | |
[ class | |
"position-absolute top-50 start-50 translate-middle" | |
, style "width: 400px" | |
] | |
[ h2 [] [text "Cypher System Tasks"] | |
, form | |
[ Attribute "hx-post" "./" | |
, Attribute "hx-target" "#result" | |
, Attribute "hx-swap" "innerHTML" | |
] | |
[ html.table | |
[style "width: 100%"] | |
[ colgroup | |
[] | |
[ col | |
[ Attribute "span" "1" | |
, style "width: 40%" | |
] | |
, col | |
[ Attribute "span" "1" | |
, style "width: 20%" | |
] | |
] | |
, tbody | |
[] | |
[ tr | |
[] | |
[ td | |
[] | |
[label [] [text "Task Difficulty"]] | |
, td | |
[] | |
[ input | |
[ Attribute "required" "true" | |
, Attribute "type" "number" | |
, Attribute "min" "0" | |
, Attribute "max" "10" | |
, name "difficulty" | |
, Attribute "value" "10" | |
] | |
] | |
] | |
, tr | |
[] | |
[ td [] [label [] [text "Skills"]] | |
, td | |
[] | |
[ input | |
[ Attribute "required" "true" | |
, Attribute "type" "number" | |
, Attribute "min" "0" | |
, Attribute "max" "2" | |
, name "skills" | |
, Attribute "value" "0" | |
] | |
] | |
] | |
, tr | |
[] | |
[ td [] [label [] [text "Assets"]] | |
, td | |
[] | |
[ input | |
[ Attribute "required" "true" | |
, Attribute "type" "number" | |
, Attribute "min" "0" | |
, Attribute "max" "2" | |
, name "assets" | |
, Attribute "value" "0" | |
] | |
] | |
] | |
, tr | |
[] | |
[ td [] [label [] [text "Effort"]] | |
, td | |
[] | |
[ input | |
[ Attribute "required" "true" | |
, Attribute "type" "number" | |
, Attribute "min" "0" | |
, Attribute "max" "6" | |
, name "effort" | |
, Attribute "value" "0" | |
] | |
] | |
] | |
, tr | |
[] | |
[ td [] [] | |
, td | |
[] | |
[ button | |
[ Attribute "display" "block" | |
, Attribute "margin" "auto" | |
, class "btn btn-primary" | |
] | |
[text "Roll!"] | |
] | |
] | |
] | |
] | |
] | |
, div | |
[ Attribute.id "result" | |
, Attribute "text-align" "center" | |
] | |
[] | |
] | |
] | |
, script | |
[ src | |
"https://cdn.jsdelivr.net/npm/[email protected]/dist/js/bootstrap.bundle.min.js" | |
, Attribute | |
"integrity" | |
"sha384-C6RzsynM9kWDrMNeT87bh95OGNyZPhcTNXj1NW7RuBCsyN/o0jlpcV8Qyq46cDfL" | |
, Attribute "crossorigin" "anonymous" | |
] | |
[] | |
] | |
])) | |
getQueryParam : Text -> Text -> '{Exception} Text | |
getQueryParam queryParam queryParameters = | |
do | |
use Text ++ | |
possibleParam = | |
parseTextMaybe | |
(Parser.query '(ParseQuery.text queryParam)) queryParameters | |
match possibleParam with | |
Some (Some paramValue) -> paramValue | |
_ -> | |
Exception.raise | |
(Generic.failure | |
("Query parameter " ++ queryParam ++ " not found.") possibleParam) | |
tryTask : TaskAttempt -> '{Exception, Random} (Nat, Boolean) | |
tryTask taskAttempt = do | |
use Nat * + - >= | |
easing = skills taskAttempt + assets taskAttempt + effort taskAttempt | |
diceRoll = base.abilities.Random.natIn 1 21 | |
adjustedDifficulty = difficulty taskAttempt - easing | |
success = diceRoll >= (adjustedDifficulty * 3) | |
(diceRoll, success) | |
parseAsNat : Text -> '{Exception} Nat | |
parseAsNat value = | |
do | |
result = Nat.fromText value | |
match result with | |
Some natValue -> natValue | |
_ -> | |
Exception.raise | |
(Generic.failure "Count not parse value as natural." value) | |
taskAttemptToText : TaskAttempt -> Text | |
taskAttemptToText attempt = | |
use Nat toText | |
use Text ++ | |
"TaskAttempt{difficulty = " | |
++ (toText <| difficulty attempt) | |
++ ", skills = " | |
++ (toText <| skills attempt) | |
++ ", assets = " | |
++ (toText <| assets attempt) | |
++ ", effort = " | |
++ (toText <| effort attempt) | |
++ "}" | |
getResultText : Boolean -> Nat -> Text | |
getResultText = cases | |
false, 1 -> "failure with a GM Intrusion!" | |
false, _ -> "failure!" | |
true, 17 -> "success with 1 additional point of damage!" | |
true, 18 -> "success with 2 additional points of damage!" | |
true, 19 -> "success with a minor effect!" | |
true, 20 -> "success with a major effect!" | |
true, _ -> "success!" | |
service.taskCheck : '{Route, Exception, Remote, Random, Log} () | |
service.taskCheck = | |
do | |
use Text ++ | |
Route.noCapture POST top | |
body = !bodyUtf8 | |
asQueryParams = "?" ++ body | |
difficulty = getQueryParam "difficulty" asQueryParams () | |
difficultyValue = parseAsNat difficulty () | |
skills = getQueryParam "skills" asQueryParams () | |
skillsValue = parseAsNat skills () | |
assets = getQueryParam "assets" asQueryParams () | |
assetsValue = parseAsNat assets () | |
effort = getQueryParam "effort" asQueryParams () | |
effortValue = parseAsNat effort () | |
attempt = TaskAttempt difficultyValue skillsValue assetsValue effortValue | |
let | |
(diceRoll, success) = tryTask attempt () | |
info | |
"taskCheck" | |
[ ("attempt", taskAttemptToText attempt) | |
, ("diceRoll", Nat.toText diceRoll) | |
, ("success", Boolean.toText success) | |
] | |
resultMessage = | |
"Rolled a " | |
++ Nat.toText diceRoll | |
++ " which is a " | |
++ getResultText success diceRoll | |
ok.html (html.toText (html.span [] [html.text resultMessage])) | |
taskService : HttpRequest ->{Exception, Remote, Random, Log} HttpResponse | |
taskService = | |
use Route <|> | |
Route.run (taskForm <|> taskCheck) | |
deploy : '{IO, Exception} URI | |
deploy = Cloud.main do | |
serviceHash = deployHttp !Environment.default taskService | |
name = ServiceName.create "taskService" | |
ServiceName.assign name serviceHash | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment