From e4f85473d5f57421239764d648ca6c4b2be43ddb Mon Sep 17 00:00:00 2001 From: Max Wilson Date: Fri, 5 Jan 2024 15:29:38 -0800 Subject: [PATCH] (red) proto1 test is correctly detecting lack of implementation for detecting whether an offer is selected or not. nested either test is (red) because it is correctly detecting that we are not short-circuiting display, i.e. should be hiding grandchildren until child is selected. --- src/Core/Common.fs | 4 +- test/Chargen.Accept.fs | 201 ++++++++++++++++++++++++++++++++++++----- 2 files changed, 182 insertions(+), 23 deletions(-) diff --git a/src/Core/Common.fs b/src/Core/Common.fs index 568601e..73198c5 100644 --- a/src/Core/Common.fs +++ b/src/Core/Common.fs @@ -13,8 +13,8 @@ let matchfail v = sprintf "No match found for %A. This is a bug." v |> invalidOp let ignoreM (_, monad) = (), monad exception BugException of msg: string /// Placeholder while we're doing type-focused development, before implementation -let notImpl v = failwith $"Not implemented yet. Email Max if you want this feature. {v}" -let shouldntHappen arg = +let inline notImpl v = failwith $"Not implemented yet. Email Max if you want this feature. {v}" +let inline shouldntHappen arg = $"This shouldn't ever happen. If it does there's a bug. Details: {arg}" |> BugException |> raise let inline breakHere() = System.Diagnostics.Debugger.Break() diff --git a/test/Chargen.Accept.fs b/test/Chargen.Accept.fs index 051fd82..bb80b40 100644 --- a/test/Chargen.Accept.fs +++ b/test/Chargen.Accept.fs @@ -19,20 +19,33 @@ type 't Output = 't * MenuOutput type 't ListOutput = ('t list) Output type 't OptionOutput = ('t option) Output -type Key = string +type KeySegment = string +type 't ReversedList = 't list +type Key = KeySegment ReversedList +type OfferConfig = { + key: KeySegment option + label: string option + } + with static member blank = { key = None; label = None } type OfferInput = { selected: Set + prefix: KeySegment ReversedList } - with static member fresh = { selected = Set.empty } -type 't Offer = Offer of (OfferInput -> 't) + with + static member fresh = { selected = Set.empty; prefix = [] } + member input.fullKey config = + input.fullKey config.key + member input.fullKey (segment: KeySegment option) = + match segment with Some k -> k::input.prefix | None -> input.prefix + member input.extend (config: OfferConfig) = { input with prefix = input.fullKey config } + member input.extend (segment: KeySegment option) = { input with prefix = input.fullKey segment } + +type 't Offer = { config: OfferConfig; func: (OfferConfig -> OfferInput -> 't * MenuOutput) } + with + member this.recur input = this.func this.config input type 't ListOffer = ('t list) Offer type 't OptionOffer = ('t option) Offer -type OfferConfig = { - key: Key option - label: string option - } - with static member blank = { key = None; label = None } open type OfferConfig type 'reactElement RenderApi = { @@ -71,15 +84,95 @@ let render (render: 'reactElement RenderApi) (menus: MenuOutput list) = menus |> List.map (recur true render.unconditional) |> render.combine type Op = - static member skill v: 't OptionOffer = notImpl() - static member trait' v: 't OptionOffer = notImpl() + static member offer(config, func) = { config = config; func = func } + static member offer func = Op.offer(OfferConfig.blank, func) + + static member skill (name: string, level: int): _ OptionOffer = + Op.skill({ OfferConfig.blank with label = Some $"{name} %+d{level}" }, (name, [level])) + static member skill (name: string, levels: int list): _ OptionOffer = + Op.skill(OfferConfig.blank, (name, levels)) + static member skill (config, (name: string, levels: int list)): _ OptionOffer = + Op.offer(config, fun config input -> None, (Leaf (defaultArg config.label (toString name)))) + + static member trait' (v: 't): 't OptionOffer = + Op.trait'({ OfferConfig.blank with key = Some (toString v) }, v) + static member trait' (config, v): 't OptionOffer = + Op.offer(config, fun config input -> Some v, (Leaf (defaultArg config.label (toString v)))) + static member budgeted v: 't ListOffer = notImpl() - static member either v : 't OptionOffer = notImpl() - static member and' v : 't OptionOffer = notImpl() - static member eitherN v : 't ListOffer = notImpl() - static member andN' v : 't ListOffer = notImpl() - static member promote (o: 't OptionOffer): 't ListOffer = notImpl() - static member evaluate (state: OfferInput) (offers: _ Offer list) = notImpl() + + static member either options : 't OptionOffer = + Op.either(OfferConfig.blank, options) + static member either (config, options: 't OptionOffer list) : 't OptionOffer = + Op.offer( + config, + fun config input -> + let children = [ + for o in options do + let (value, menu) = o.recur input + let key = o.config.key |> Option.orElse o.config.label + let fullKey = input.fullKey key + let selected = key.IsSome && input.selected.Contains fullKey + value, (selected, menu) + ] + let selectedValue = children |> List.tryPick fst // if this were eitherN we'd return them all but since it's regular either we return the first one, if any + let childMenus = children |> List.map snd + selectedValue, Either(config.label, childMenus) + ) + + static member eitherN (options: 't OptionOffer list) : 't ListOffer = + Op.eitherN(OfferConfig.blank, options) + static member eitherN (options: 't ListOffer list) : 't ListOffer = + Op.eitherN(OfferConfig.blank, options) + static member eitherN (config, options: 't OptionOffer list) : 't ListOffer = + Op.eitherN(config, options |> List.map (fun o -> Op.promote o)) + static member eitherN (config, options: 't ListOffer list) : 't ListOffer = + Op.offer( + config, + fun config input -> + let children = [ + for o in options do + let key = o.config.key |> Option.orElse o.config.label + let (value, menu) = o.recur (input.extend key) // we only need the key to distinguish between eithers, not ands, so we extend the input by the child key only for either + let fullKey = input.fullKey key + let selected = key.IsSome && input.selected.Contains fullKey + value, (selected, menu) + ] + let selectedValues = children |> List.collect fst + let childMenus = children |> List.map snd + selectedValues, Either(config.label, childMenus) + ) + static member and' (offers: 't OptionOffer list) : 't ListOffer = + Op.and'(OfferConfig.blank, offers) + static member and' (offers: 't ListOffer list) : 't ListOffer = + Op.and'(OfferConfig.blank, offers) + static member and' (config, offers: 't OptionOffer list) : 't ListOffer = + Op.and'(config, offers |> List.map (fun o -> Op.promote o)) + static member and' (config, offers: 't ListOffer list) : 't ListOffer = + Op.offer( + config, + fun config input -> + let children = [ + for o in offers do + // we only need the key to distinguish between eithers, not ands, so we extend the input by the child key only for either + let (value, menu) = o.recur input + value, menu + ] + let selectedValues = children |> List.collect fst + let childMenus = children |> List.map snd + selectedValues, And(config.label, childMenus) + ) + + static member promote (o: 't OptionOffer): 't ListOffer = + Op.offer( + o.config, + fun config input -> + let (v, menu) = o.recur input + List.ofOption v, menu + ) + static member evaluate (state: OfferInput) (offer: _ Offer) = + offer.recur state + let newKey txt = $"{txt}-{System.Guid.NewGuid()}" let label txt = { blank with label = Some txt } open type Op @@ -107,15 +200,15 @@ let swash(): Trait' ListOffer list = [ skill("Acrobatics", [1..3]) ]) let mainWeapons = ["Rapier"; "Broadsword"; "Polearm"; "Two-handed sword"] |> List.map (fun name -> name, newKey name) - let weaponsAt (bonus: int) = mainWeapons |> List.map (fun (name, key) -> skill({ blank with key = Some key }, name, bonus)) + let weaponsAt (bonus: int) = mainWeapons |> List.map (fun (name, key) -> skill({ blank with key = Some key }, (name, [bonus]))) eitherN [ either(label "Sword!", weaponsAt +5) |> promote - andN'(label "Sword and Dagger", [either(weaponsAt +4); skill("Main-gauche", +1)]) - andN'(label "Sword and Shield", [either(weaponsAt +4); skill("Shield", +2)]) + and'(label "Sword and Dagger", [either(weaponsAt +4); skill("Main-gauche", +1)]) + and'(label "Sword and Shield", [either(weaponsAt +4); skill("Shield", +2)]) ] eitherN [ skill("Fast-draw (Sword)", +2) |> promote - andN'([skill("Fast-draw (Sword)", +1); skill("Fast-draw (Dagger)", +1)]) + and'([skill("Fast-draw (Sword)", +1); skill("Fast-draw (Dagger)", +1)]) ] ] @@ -155,8 +248,74 @@ let pseudoReactApi = { combine = Fragment } +let evalFor (selections: string list) offers = + let parseKey (key: string) : Key = + key.Split("-") |> List.ofArray |> List.rev + let keys: Set = selections |> List.map parseKey |> Set.ofSeq + evaluate { OfferInput.fresh with selected = keys } offers |> snd +[] +let units = testList "Unit.Chargen" [ + testCase "basic either" <| fun () -> + test <@ either[trait' "Fight"; trait' "Hide"] |> evalFor [] = Either(None, [false, Leaf "Fight"; false, Leaf "Hide"]) @> + test <@ either[trait' "Fight"; trait' "Hide"] |> evalFor ["Fight"] = Either(None, [true, Leaf "Fight"; false, Leaf "Hide"]) @> + testCase "nested either with list" <| fun () -> + let nestedEither = eitherN [ + either(label "Sword!", [skill("Rapier", +5); skill("Broadsword", +5); skill("Shortsword", +5)]) |> promote + and'(label "Sword and Dagger", [ + either [skill("Rapier", +4); skill("Broadsword", +4); skill("Shortsword", +4)] + skill("Main-gauche", +1) + ]) + and'(label "Sword and Shield", [ + either [skill("Rapier", +4); skill("Broadsword", +4); skill("Shortsword", +4)] + skill("Shield", +2) + ]) + ] + let empty = + Either(None, [ + true, Either(Some "Sword!", [ + false, Leveled("Rapier", +5) + false, Leveled("Broadsword", +5) + false, Leveled("Shortsword", +5) + ]) + ]) + test <@ nestedEither |> evalFor [] = + Either(None, [ + false, Either(Some "Sword!", []) + false, Either(Some "Sword and Dagger!", []) + false, Either(Some "Sword and Shield!", []) + ]) @> + test <@ nestedEither |> evalFor ["Sword!"] = + Either(None, [ + true, Either(Some "Sword!", [ + false, Leveled("Rapier", +5) + false, Leveled("Broadsword", +5) + false, Leveled("Shortsword", +5) + ]) + ]) @> + test <@ nestedEither |> evalFor ["Sword!"; "Sword!-Rapier"] = + Either(None, [ + true, Either(Some "Sword!", [ + true, Leveled("Rapier", +5) + ]) + ]) @> + test <@ nestedEither |> evalFor ["Sword and Dagger"] = + Either(None, [ + true, Either(Some "Sword and Dagger", [ + true, And(None, [ + Either(None, [ + false, Leveled("Rapier", +5) + false, Leveled("Broadsword", +5) + false, Leveled("Shortsword", +5) + ]) + Leveled("Main-gauche", +1) + ]) + ]) + ]) @> + let selectFight = { OfferInput.fresh with selected = Set.ofList [["Fight"]] } + test <@ either[trait' "Fight"; trait' "Hide"] |> evaluate selectFight |> snd = Either(None, [true, Leaf "Fight"; false, Leaf "Hide"]) @> + ] let proto1 = testCase "proto1" <| fun () -> - let actual = swash() |> evaluate OfferInput.fresh // shouldn't actually use OfferInput.fresh here. Need to pick the options we want to show up in pseudoActual.s + let actual = swash() |> List.map (evaluate OfferInput.fresh >> snd) // shouldn't actually use OfferInput.fresh here. Need to pick the options we want to show up in pseudoActual.s let pseudoActual = // pseudo-actual because actual will be created from templates + OfferInput (i.e. selected keys), not hardwired as Menus, but that's still TODO let menus = [ Leveled("Climbing", 1)