fantasy-vacation-planner/main.scm

(import
  (except (rnrs base) let-values map error vector-map)
  (only (guile)
        lambda* λ
        current-output-port
        simple-format
        command-line)
  ;; SRFIs
  ;; srfi-1 list and alist procs
  (srfi srfi-1)
  ;; srfi-8 for receive form
  (srfi srfi-8)
  ;; srfi-9 for structs
  (srfi srfi-9)
  (srfi srfi-9 gnu)
  ;; srfi-69 for hash tables
  (srfi srfi-69)
  ;; srfi-43 for vector procs
  (srfi srfi-43)

  ;; Libraries
  (json)
  ;; custom, not here implemented, libraries
  (fslib)
  ;; custom modules
  (lib math-procs)
  (lib alist-procs)
  (lib list-procs)
  (lib vector-procs)
  (lib fileio)
  (lib filesystem)
  (lib random)
  (lib user-input-output)
  (lib string-procs)
  (lib set)
  (prefix (lib logger) log:)
  (config)
  (model)
  (data-abstraction)
  (effect))


;; =====
;; EVENT
;; =====
(define calculate-event-probability
  (λ (event general-config)
    (let ([base-prob (alist-ref event "probability")]
          [prob-multiplier (alist-nested-refs general-config '("difficulty"))]
          [min-prob (alist-nested-refs general-config '("min-probability"))]
          [max-prob (alist-nested-refs general-config '("max-probability"))])
      (limit-by-interval (* base-prob prob-multiplier)
                         min-prob
                         max-prob))))


(define event-happening?
  (lambda* (event general-config #:key (random-state #f))
    (log:debug
     (string-format "Checking if event ~a is happening ..." (alist-ref event "name")))
    (try-for-probability
     (calculate-event-probability event general-config)
     #:random-state random-state)))


(define handle-effects
  (λ (effects traveler-state transportation-configs effect-procs)
    "Handle effects in the order, in which they are
specified in the story parameters."
    (vector-fold
     (λ (ind acc-event-outcome effect)
       ;; Get the appropriate effect procedure and update
       ;; the traveler state using it. An effect procedure
       ;; gets the traveler's state and the story
       ;; parameters, in case it needs them for any reason.
       (log:debug (string-format "processing effect: ~a" effect))
       (log:debug (string-format "current event-outcome: ~a" acc-event-outcome))
       ((hash-table-ref effect-procs effect)
        acc-event-outcome traveler-state transportation-configs))
     (make-event-outcome)
     effects)))


(define describe-event-to-player
  (λ (event)
    (confirm-info-message (string-format "EVENT name: ~a" (alist-ref event "name")))
    (confirm-info-message (string-format "EVENT description: ~a" (choose-random-element (alist-ref event "explanations"))))
    (confirm-info-message (string-format "EVENT effects: ~a" (alist-ref event "default-effects")))))


(define handle-event-actions
  (λ (event traveler-state transportation-configs effect-procs)
    (log:debug (string-format "handling event ~a" (alist-ref event "name")))
    (let ([actions (alist-ref event "actions")])
      ;; Ask the user for a decision, which will result in
      ;; an event outcome.
      (log:debug (string-format "event has the following actions: ~a" actions))

      (ask-user-for-decision-with-continuations
       "How do you want to react?"
       (map number->string (range 1 (+ (vector-length actions) 1) #:end-inclusive #t))
       (append
        (vector->list
         (vector-map (λ (ind action) (alist-ref action "label")) actions))
        ;; add "other" case for people to specify their own action
        '("other"))
       (append
        (vector->list
         (vector-map (λ (ind action)
                       ;; Return a procedure, which will
                       ;; result in an event outcome when
                       ;; applied. The event outcome depends
                       ;; on the effects of the event.
                       (log:debug "vector map from actions to effect handling lambdas")
                       (λ ()
                         (confirm-info-message (alist-ref action "description"))
                         (handle-effects (alist-ref action "effects")
                                         traveler-state
                                         transportation-configs
                                         effect-procs)))
                     actions))
        ;; add custom action query and handling for "other"
        (list (λ ()
                (log:debug "will query for custom action")
                (let ([custom-action (query-user-for-custom-action)])
                  (handle-effects (alist-ref custom-action "effects")
                                  traveler-state
                                  transportation-configs
                                  effect-procs)))))))))


(define calculate-event-outcome
  (λ (event traveler-state transportations-config effect-procs)
    "Calculate an event outcome from the event action's
effects or the fallback effects of the event itself."
    (let ([event-description (choose-random-element (alist-ref event "explanations"))]
          [event-effects (alist-ref event "default-effects")]
          [event-actions (alist-ref event "actions")])
      ;; If the event has actions to choose from, then let
      ;; the player choose and process the effects of their
      ;; choice of action. Otherwise use the fallback
      ;; effects stored in the event, if there are any.
      (cond
       [(vector-empty? event-actions)
        (cond
         [(null? event-effects)
          (log:debug "The event has no effects, returning default event outcome.")
          (make-event-outcome)]
         [else
          (log:debug "event has effects itself, calculating event outcome")
          (handle-effects event-effects
                          traveler-state
                          transportations-config
                          effect-procs)])]
       [else
        (log:debug "event has actions, will handle event actions")
        (handle-event-actions event
                              traveler-state
                              transportations-config
                              effect-procs)]))))

(define process-event
  (λ (event
      events
      event-groups
      traveler-state
      transportations-config
      effect-procs
      ;; continuations
      next-event next-event-group next-step)
    "Process an event. Processing an event has an event
outcome, according to which the traveler state is updated
and the journey continues."
      (describe-event-to-player event)
      ;; Calculate the event outcome and then act according
      ;; to it.
      (let ([event-outcome
             (calculate-event-outcome
              event traveler-state transportations-config effect-procs)])
        ;; Update route and numerical values of the traveler
        ;; state upfront and then handle the specifics of
        ;; the event outcome.
        (let ([updated-traveler-state
               (set-fields traveler-state
                           ((traveler-route)
                            ;; If a route is returned in the
                            ;; event outcome, use that
                            ;; route, otherwise keep the one
                            ;; in the traveler state.
                            (or (event-outcome-updated-route event-outcome)
                                (traveler-route traveler-state)))
                           ((journey-delay) (event-outcome-additional-delay event-outcome))
                           ((additional-costs) (event-outcome-additional-costs event-outcome)))])
          (log:debug (string-format "updated traveler state: ~a" updated-traveler-state))
          (cond
           [(event-outcome-route-changed event-outcome)
            (log:debug "event outcome has an updated route")
            (log:debug "going to next step of the journey")
            (next-step updated-traveler-state)]

           [(event-outcome-disable-event-group event-outcome)
            (log:debug "event outcome has disabled other events of the same event group")
            (log:debug "checking next event group")
            (next-event-group (rest event-groups) updated-traveler-state)]

           [(event-outcome-disable-events event-outcome)
            (log:debug "event outcome has disabled other events for this step of the journey")
            (log:debug "going to next step of the journey")
            (next-step updated-traveler-state)]

           [else
            (log:debug "going to next event")
            (next-event (rest events) updated-traveler-state)])))))


(define travel
  (lambda* (init-traveler-state
            general-config
            transportations-config
            effect-procs
            #:key
            (random-state #f)
            (random-int-gen (make-random-integer-generator)))
    "Calculate the cost for one traveler travelling to the
destination of their journey."

    ;; Iterate through the route, which consists of steps of the journey.
    (let next-step ([traveler-state init-traveler-state])
      (cond
       ;; If there are no more steps, the traveler has arrived at their
       ;; destination. Return the additional costs.
       [(null? (traveler-route traveler-state))
        (confirm-info-message (string-format "Congratulations ~a, you reached your destination!" (traveler-name traveler-state)))
        traveler-state]
       ;; Otherwise continue with the current step of the journey.
       [else
        (let* ([step (first (traveler-route traveler-state))]
               [from (alist-ref step "from")]
               [to (alist-ref step "to")]
               [transportation (alist-ref step "transportation")]
               [event-groups (get:event-groups transportations-config transportation)])
          (log:debug (string-format "event groups for this step are: ~a" event-groups))
          (confirm-info-message (string-format "~a you are currently in/at: ~a" (traveler-name traveler-state) from))
          (confirm-info-message (string-format "~a you are taking the ~a from ~a to ~a" (traveler-name traveler-state) transportation from to))
          ;; Iterate through the event groups.
          (let next-event-group ([remaining-event-groups event-groups]
                                 [traveler-state traveler-state])
            (cond
             ;; If there are no event groups remaining to handle, continue
             ;; with the next route part.
             [(null? remaining-event-groups)
              (log:debug "no more event groups in this step")
              (next-step
               (set-traveler-route traveler-state
                                   (rest (traveler-route traveler-state))))]
             [else
              (log:debug (string-format "Looking at events in event group ~s now ..." (first (first remaining-event-groups))))
              ;; Iterate through the events of the event group and break out,
              ;; if required.
              (let next-event ([remaining-events
                                (get:event-group/events (first remaining-event-groups))]
                               [current-traveler-state traveler-state])

                ;; Handle the events in the group of events,
                ;; if there are any.
                (cond
                 ;; If there are no events left to handle, continue with the
                 ;; next event group.
                 [(null? remaining-events)
                  (log:debug "no more events in this event group")
                  (next-event-group (rest remaining-event-groups) current-traveler-state)]
                 [else
                  ;; If there are events remaining, deal with the events.
                  (let ([event (first remaining-events)])
                    ;; Check if an event is happening and
                    ;; process the event and its effects, if
                    ;; it does happen.
                    (cond
                     [(event-happening? event general-config #:random-state random-state)
                      (log:debug (string-format "event ~a is happening" (alist-ref event "name")))
                      ;; If the event does happen, handle
                      ;; the event.  Display the event
                      ;; explanation.
                      (process-event event
                                     remaining-events
                                     remaining-event-groups
                                     current-traveler-state
                                     transportations-config
                                     effect-procs
                                     ;; continuation procedures -- hand those
                                     ;; in, so that the return value does not
                                     ;; have to be processed
                                     next-event
                                     next-event-group
                                     next-step)]
                     [else
                      ;; If the event does not happen recur
                      ;; with 0 additional cost.
                      (next-event (rest remaining-events) current-traveler-state)]))]))])))]))))


(define process-traveler
  (lambda* (traveler general-config json-doc-story-params effect-procs
            #:key
            (random-state #f)
            (random-int-gen (make-random-integer-generator)))
    "Process a single traveler."
    (confirm-info-message (string-format "~a this is the start of your journey." (first traveler)))
    (let* ([planned-costs
            (ask-user-for-number
             (string-format "~a, how much does the transportation to your destination cost?"
                            (first traveler))
             (λ (num) #t))]
           [init-state
            (make-traveler-state (first traveler)
                                 (get:traveler/route traveler)
                                 planned-costs
                                 #:journey-delay 0
                                 #:additional-costs 0)])
      ;; TODO: think about return value of travel procedure
      (travel init-state
              general-config
              json-doc-story-params
              effect-procs
              #:random-state random-state
              #:random-int-gen random-int-gen))))


;; ====
;; MAIN
;; ====
(define main
  (λ ()
    (receive (transportations-config players-config general-config)
        (get-configuration)

      #;(log:debug
       (string-format "TRANSPORTATIONS-CONFIG: ~a" transportations-config))

      (let ([initial-random-state (seed->random-state 12345)]
            [random-int-gen (make-random-integer-generator #:seed 12345)])
        (let ([effect-procs
               (alist->hash-table
                `(("delay" . ,journey-delay-effect)
                  ("additional-costs" . ,additional-costs-effect)
                  ("unusable" . ,unusable-effect)
                  ("route-change" . ,route-change-effect)
                  ("disable-other-events" . ,disable-other-events-effect)))])
          (map
           (λ (player-config)
             (process-traveler player-config
                               general-config
                               transportations-config
                               effect-procs
                               #:random-state initial-random-state
                               #:random-int-gen random-int-gen))
           players-config))))))


(log:info (string-format "result: ~a" (main)))