fantasy-vacation-planner/effect.scm

(library (effect)
  (export query-user-for-new-route-part
          query-user-for-custom-action
          modify-route
          ;; effects
          journey-delay-effect
          additional-costs-effect
          unusable-effect
          route-change-effect
          disable-other-events-effect)
  (import
    (except (rnrs base) let-values map error)
    (only (guile)
          lambda* λ)
    (srfi srfi-1)
    (srfi srfi-9 gnu)

    (lib user-input-output)
    (lib list-procs)
    (lib alist-procs)
    (prefix (lib logger) log:)

    (model)
    (data-abstraction)))


(define query-user-for-effects
  (λ ()
    (log:debug "querying for custom effects")
    (let ([known-effects '("delay" "additional-costs" "route-change")])
      (list->vector
       (filter (λ (eff)
                 (ask-user-for-yes-no-decision
                  (string-format "Does your action cause ~a?" eff)
                  '("y" "yes") '("n" "no")))
               known-effects)))))


(define query-user-for-custom-action
  (λ ()
    (log:debug "querying for custom action")
    (confirm-info-message "Please describe your action.")
    (let ([label (ask-user-for-text "label")]
          [karma
           (ask-user-for-number "karma (number, [-5,+5])"
                                (λ (num) (and (>= num -5) (<= num 5))))]
          [description (ask-user-for-text "description")]
          [effects (query-user-for-effects)])
      `(("label" . ,label)
        ("karma" . ,karma)
        ("description" . ,description)
        ("effects" . ,effects)))))


(define query-user-for-new-route-part
  (λ (story-params)
    (let ([from-location (ask-user-for-text "From?")]
          [to-location (ask-user-for-text "To?")]
          [transportation
           (let ([means-of-transportation
                  (get-all-means-of-transportation story-params)])
             (ask-user-for-decision-with-continuations
              "Means of transportation?"
              (map number->string
                   (range 1 (length means-of-transportation) #:end-inclusive #t))
              means-of-transportation
              (map (λ (transp) (λ () transp)) means-of-transportation)))
           #;(ask-user-for-decision "Means of transportation?"
                                  (get-all-means-of-transportation story-params))])
      `(("from" . ,from-location)
        ("to" . ,to-location)
        ("transportation" . ,transportation)))))


(define modify-route
  (λ (route story-params)
    (let next-change ([modified-route route])
      (confirm-info-message (string-format "Currently planned route:\n~a" (route->string modified-route)))
      (let ([choice-numbers
             (if (null? modified-route) '("1" "2" "3") '("1" "2" "3" "4"))]
            [choice-texts
             (if (null? modified-route)
                 '("add route part"
                   "specify new route"
                   "finish modifying route")
                 '("remove first route part"
                   "prepend route part"
                   "specify new route"
                   "finish modifying route"))]
            [choice-actions
             (if (null? modified-route)
                 (list (λ ()
                         (next-change (cons (query-user-for-new-route-part story-params) modified-route)))
                       (λ ()
                         (confirm-info-message "not yet implemented") (next-change modified-route))
                       (λ ()
                         (let ([response (ask-user-for-yes-no-decision
                                          "Are you sure you are finished modifying your route?"
                                          '("y" "yes") '("n" "no"))])
                           (if response modified-route (next-change modified-route)))))
                 (list (λ ()
                         (next-change (rest modified-route)))
                       (λ ()
                         (next-change (cons (query-user-for-new-route-part story-params) modified-route)))
                       (λ ()
                         (confirm-info-message "not yet implemented") (next-change modified-route))
                       (λ ()
                         (let ([response (ask-user-for-yes-no-decision
                                          "Are you sure you are finished modifying your route?"
                                          '("y" "yes")
                                          '("n" "no"))])
                           (if response modified-route (next-change modified-route))))))])
        (ask-user-for-decision-with-continuations
         "What do you want to do?" choice-numbers choice-texts choice-actions)))))


;; =================
;; EFFECT PROCEDURES
;; =================
(define journey-delay-effect
  (λ (event-outcome traveler-state transportation-configs)
    (set-event-outcome-additional-delay
     event-outcome
     (+ (event-outcome-additional-delay event-outcome)
        (ask-user-for-number "How much delay was caused by this?"
                             (λ (num) #t))))))


(define additional-costs-effect
  (λ (event-outcome traveler-state transportation-configs)
    (set-event-outcome-additional-costs
     event-outcome
     (+ (event-outcome-additional-costs event-outcome)
        (ask-user-for-number "How much additional costs were caused by this?"
                             (λ (num) #t))))))


(define unusable-effect
  (λ (event-outcome traveler-state transportation-configs)
    (confirm-info-message "The event rendered your current means of transporation unusable.")
    ;; NOTE: Perhaps we need to implement something here,
    ;; but currently the "unusable" effect functionality is
    ;; covered by the route-change effect.
    event-outcome))


(define route-change-effect
  (λ (event-outcome traveler-state transportation-configs)
    (confirm-info-message "The event requires you to change your route.")
    (let ([route (traveler-route traveler-state)])
      (confirm-info-message (string-format "Your current route is:\n~a" (route->string route)))
      (confirm-info-message (string-format "The first route part will be removed: ~a" (route-part->string (first route))))
      (confirm-info-message
       (string-format
        "Your current location is between ~a and ~a."
        (alist-ref (first route) "from")
        (alist-ref (first route) "to")))
      (set-fields event-outcome
                  ((event-outcome-updated-route)
                   (modify-route (rest route) transportation-configs))
                  ((event-outcome-route-changed)
                   #t)))))


(define disable-other-events-effect
  (λ (event-outcome traveler-state transportation-configs)
    (confirm-info-message
     "(The event disables other events of the same event group.).")
    (set-event-outcome-disable-event-group event-outcome #t)))