Skip to content

Instantly share code, notes, and snippets.

@seanparsons

seanparsons/scratch.u

Created February 13, 2024 10:31
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save seanparsons/c0431e873c25a544170cdf3a80661622 to your computer and use it in GitHub Desktop.
Save seanparsons/c0431e873c25a544170cdf3a80661622 to your computer and use it in GitHub Desktop.
Download ZIP
Cypher System Tasks Experiment
Raw
scratch.u
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/htmx.org@1.9.10/dist/htmx.min.js"] []
, html.link
[ href
"https://cdn.jsdelivr.net/npm/bootstrap@5.3.2/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/bootstrap@5.3.2/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