+(define-class <dancers> (<chatty-npc>)
+ (commands
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ (("dance") ((direct-command cmd-dance)))))
+ (actions #:allocation #:each-subclass
+ #:init-thunk
+ (build-actions
+ (cmd-dance cmd-dance-dancers))))
+
+(define* (cmd-dance-dancers actor message #:key direct-obj)
+ (define player (message-from message))
+ (define player-loc (mbody-val (<-wait player 'get-loc)))
+ (define player-name (mbody-val (<-wait player 'get-name)))
+ (<- (message-from message) 'tell
+ #:text '((p "You join in dancing with the dancers. You spin and
+get woozy... you feel wonderful... like you could dance forever...")
+ (p "You step out just in time, lest you be caught in
+the dancing for eternity!")))
+ (<- player-loc 'tell-room
+ #:text `((p ,player-name " begins dancing with the fairies and
+spins around and around... as if they might dance forever!")
+ (p "But " ,player-name " steps back just in time!
+Their eyes are cloudy and woozy, but they look happy..."))
+ #:exclude player))
+
+(define-class <swing> (<gameobj>)
+ (commands
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ (("sit" "swing") ((direct-command cmd-swing)))))
+ (actions #:allocation #:each-subclass
+ #:init-thunk
+ (build-actions
+ (cmd-swing cmd-swing-on-swing))))
+
+(define* (cmd-swing-on-swing actor message #:key direct-obj)
+ (define player (message-from message))
+ (define player-loc (mbody-val (<-wait player 'get-loc)))
+ (define player-name (mbody-val (<-wait player 'get-name)))
+ (<- (message-from message) 'tell
+ #:text '((p "You swing on the swing and feel younger again
+as you rock to the motion, as if your movements resemble your
+traversal through the flow of time itself. You feel happy.")))
+ (<- player-loc 'tell-room
+ #:text `((p ,player-name " looks very happy as they swing
+on the swing."))
+ #:exclude player))
+
+(define-class <fairy-go-round> (<gameobj>)
+ (commands
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ (("ride" "sit") ((direct-command cmd-ride)))))
+ (actions #:allocation #:each-subclass
+ #:init-thunk
+ (build-actions
+ (cmd-ride cmd-ride-on-fairy-go-round))))
+
+(define* (cmd-ride-on-fairy-go-round actor message #:key direct-obj)
+ (define player (message-from message))
+ (define player-loc (mbody-val (<-wait player 'get-loc)))
+ (define player-name (mbody-val (<-wait player 'get-name)))
+ (<- (message-from message) 'tell
+ #:text '((p "You ride on the fairy go round. Your vision blurs
+and refocuses into places everywhere in this realm and every other.
+You feel a part of everywhere at once for a moment, and then, you
+step off.")))
+ (<- player-loc 'tell-room
+ #:text `((p ,player-name " rides on the fairy go round and seems
+to be everywhere and nowhere at once for a moment before stepping off."))
+ #:exclude player))
+
+(define-actor <cake> (<semi-edible-chatty-npc>)
+ ((cmd-take cake-cmd-take)))
+
+(define-actor <slice-of-cake> (<gameobj>)
+ ((cmd-nibble slice-of-cake-cmd-nibble)
+ (cmd-eat slice-of-cake-cmd-eat))
+ (contained-commands
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ ("nibble" ((direct-command cmd-nibble)))
+ ("eat" ((direct-command cmd-eat)))))
+
+ (bites-left #:init-value 4
+ #:accessor .bites-left)
+ (name #:init-value "a slice of cake")
+ (take-me? #:init-value #t)
+ (goes-by #:init-value '("slice of cake" "slice" "slice of wedding cake"
+ "piece of cake" "piece of wedding cake"))
+ (desc #:init-value "It's a slice of wedding cake! You could nibble on it
+or just plain eat it!"))
+
+(define (slice-of-cake-cmd-eat slice-of-cake message . _)
+ (define player (message-from message))
+ (define player-loc (mbody-val (<-wait player 'get-loc)))
+ (define player-name (mbody-val (<-wait player 'get-name)))
+ (<- player 'tell
+ #:text "You wolf down your piece of wedding cake all at once like some
+kind of hungry animal! You're making a huge mess!")
+ (<- player-loc 'tell-room
+ #:text `(,player-name
+ " wolfs down a piece of wedding cake all at once!
+They're making a huge mess!")
+ #:exclude player)
+ (gameobj-self-destruct slice-of-cake))
+
+(define (slice-of-cake-cmd-nibble slice-of-cake message . _)
+ (define player (message-from message))
+ (define player-loc (mbody-val (<-wait player 'get-loc)))
+ (define player-name (mbody-val (<-wait player 'get-name)))
+ (set! (.bites-left slice-of-cake) (- (.bites-left slice-of-cake) 1))
+ (<- player 'tell
+ #:text "You take a nibble of your piece of wedding cake.
+How dignified!")
+ (<- player-loc 'tell-room
+ #:text `(,player-name
+ " takes a nibble of their piece of wedding cake.
+How dignified!")
+ #:exclude player)
+ (when (= (.bites-left slice-of-cake) 0)
+ (<- player 'tell
+ #:text "You've finished your slice of wedding cake!")
+ (<- player-loc 'tell-room
+ #:text `(,player-name
+ " finishes their slice of wedding cake!")
+ #:exclude player)
+ (gameobj-self-destruct slice-of-cake)))
+
+(define* (cake-cmd-take gameobj message
+ #:key direct-obj
+ (player (message-from message)))
+ (create-gameobj <slice-of-cake> (gameobj-gm gameobj)
+ player) ;; set loc to player to put in player's inventory
+ (<- player 'tell
+ #:text '((p "You slice off a piece of the tiered wedding cake.
+The cake fills itself back in as if by magic! Oh no, it's not alive, is it?")
+ (p "You take the slice of wedding cake with you.")))
+ (<- (gameobj-loc gameobj) 'tell-room
+ #:text `(,(mbody-val (<-wait player 'get-name))
+ " slices off a piece of the cake and the cake fills itself
+back in! How strange!")
+ #:exclude player))
+
+(define-class <flowers> (<gameobj>)
+ (commands
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ (("smell" "sniff") ((direct-command cmd-smell)))))
+ (actions #:allocation #:each-subclass
+ #:init-thunk
+ (build-actions
+ (cmd-smell flowers-cmd-smell))))
+
+(define* (flowers-cmd-smell actor message #:key direct-obj)
+ (define player (message-from message))
+ (define player-loc (mbody-val (<-wait player 'get-loc)))
+ (define player-name (mbody-val (<-wait player 'get-name)))
+ (<- (message-from message) 'tell
+ #:text '((p "You smell the flower and... whoa. Wait. What kind
+of flower is this?")
+ (p "You teeter as the room spins and then politely
+re-orients itself.")))
+ (<- player-loc 'tell-room
+ #:text `((p ,player-name " smells the flower and teeters around
+a bit."))
+ #:exclude player))
+
+(define-actor <frog> (<chatty-npc>)
+ ;; TODO: Add "open" verb, since obviously people will try that
+ ((cmd-kiss frog-cmd-kiss))
+ (commands
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ (("kiss") ((direct-command cmd-kiss))))))
+
+(define* (frog-cmd-kiss actor message #:key direct-obj)
+ (define player (message-from message))
+ (define player-loc (mbody-val (<-wait player 'get-loc)))
+ (define player-name (mbody-val (<-wait player 'get-name)))
+ (<- (message-from message) 'tell
+ #:text '((p "You kiss the frog. She blushes and you get a distinctly "
+ "princess'y vibe off of her!")))
+ (<- player-loc 'tell-room
+ #:text `((p ,player-name " kisses the frog! The frog blushes!"))
+ #:exclude player))
+