123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192 |
- (library (model)
- (export
- ;; traveler state
- construct-traveler-state
- make-traveler-state
- traveler-state?
- traveler-name set-traveler-name
- traveler-route set-traveler-route
- route-changed set-route-changed
- journey-delay set-journey-delay
- planned-costs set-planned-costs
- additional-costs set-additional-costs
- karma set-karma
- event-count set-event-count
- ;; ;; route part
- ;; construct-route-part
- ;; route-part?
- ;; route-part-from
- ;; set-route-part-from
- ;; route-part-to
- ;; set-route-part-to
- ;; route-part-transportation
- ;; set-route-part-transportation
- ;; route stuff
- ;; event outcome
- construct-event-outcome
- make-event-outcome
- event-outcome?
- event-outcome-additional-costs set-event-outcome-additional-costs
- event-outcome-additional-delay set-event-outcome-additional-delay
- event-outcome-karma set-event-outcome-karma
- event-outcome-route-changed set-event-outcome-route-changed
- event-outcome-updated-route set-event-outcome-updated-route
- event-outcome-disable-event-group set-event-outcome-disable-event-group
- event-outcome-disable-events set-event-outcome-disable-events
- ;; other
- display-route
- display-route-part
- route->string
- route-part->string)
- (import
- (except (rnrs base) let-values map error)
- (only (guile)
- lambda* λ
- current-output-port
- call-with-output-string
- simple-format
- command-line)
- ;; srfi-1 for list procs
- (srfi srfi-1)
- ;; srfi-9 for structs
- (srfi srfi-9)
- (srfi srfi-9 gnu)
- ;; alist
- (lib alist-procs)
- ;; strings
- (lib string-procs)
- (prefix (lib logger) log:)))
- (define-immutable-record-type <traveler-state>
- ;; constructor
- (construct-traveler-state
- name
- route
- journey-delay
- planned-costs
- additional-costs
- karma
- event-count)
- ;; predicate
- traveler-state?
- ;; getters and functional setters
- (name traveler-name set-traveler-name)
- (route traveler-route set-traveler-route)
- (journey-delay journey-delay set-journey-delay)
- (planned-costs planned-costs set-planned-costs)
- (additional-costs additional-costs set-additional-costs)
- (karma karma set-karma)
- (event-count event-count set-event-count))
- (define make-traveler-state
- (lambda* (name route planned-costs
- #:key
- (journey-delay 0)
- (additional-costs 0)
- (karma 0)
- (event-count 0))
- (construct-traveler-state
- name route journey-delay planned-costs additional-costs karma event-count)))
- (define-immutable-record-type <event-outcome>
- (construct-event-outcome additional-costs
- additional-delay
- karma
- route-changed
- updated-route
- disable-event-group
- disable-events)
- event-outcome?
- (additional-costs event-outcome-additional-costs
- set-event-outcome-additional-costs)
- (additional-delay event-outcome-additional-delay
- set-event-outcome-additional-delay)
- (karma event-outcome-karma
- set-event-outcome-karma)
- (route-changed event-outcome-route-changed
- set-event-outcome-route-changed)
- (updated-route event-outcome-updated-route
- set-event-outcome-updated-route)
- (disable-event-group event-outcome-disable-event-group
- set-event-outcome-disable-event-group)
- (disable-events event-outcome-disable-events
- set-event-outcome-disable-events))
- (define make-event-outcome
- (lambda* (#:key
- (additional-costs 0)
- (additional-delay 0)
- (karma 0)
- (route-change #f)
- (updated-route #f)
- (disable-event-group #f)
- (disable-events #f))
- (construct-event-outcome
- additional-costs
- additional-delay
- karma
- route-change
- updated-route
- disable-event-group
- disable-events)))
- (define route->string
- (λ (route)
- (call-with-output-string
- (λ (string-port)
- (display-route route #:output-port string-port)))))
- (define display-route
- (lambda* (route #:key (output-port (current-output-port)))
- ;; (log:debug (string-format "route arg in display-route: ~a" route))
- (let next-part ([route-parts route])
- (cond
- [(null? route-parts)
- (simple-format output-port "")]
- [else
- (display-route-part (first route-parts) #:output-port output-port)
- (simple-format output-port "\n")
- (next-part (cdr route-parts))]))))
- (define route-part->string
- (λ (route-part)
- (call-with-output-string
- (λ (string-port)
- (display-route-part route-part #:output-port string-port)))))
- (define display-route-part
- (lambda* (part #:key (output-port (current-output-port)))
- ;; (log:debug (string-format "route-part arg in display-route-part: ~a" part))
- (let ([transport (alist-ref part "transportation")]
- [from (alist-ref part "from")]
- [to (alist-ref part "to")])
- (simple-format output-port
- "(~a) ~a --> ~a"
- transport from to))))
|