Skip to content
Commits on Source (5)
Expand all Hide whitespace changes
Inline Side-by-side
deploy.txt
View file @ 0aee118d
(ql:quickload '(drakma cl-conspack cxml cl-statsd cl-redis qbase64 archive cl-ansi-text gzip-stream bobbin cl-heap local-time log4cl) :silent t)
(load "trackernet.lisp")
(require :sb-sprof)
(format t "** Loaded ~A track links **~%" (hash-table-size trackernet::*normalized-track-links*))
(format t "=> Loaded track links:~% ~A~%" (alexandria:hash-table-alist trackernet::*per-line-track-graph*))
(sb-ext:save-lisp-and-die "./intertube-scraper" :toplevel #'trackernet::main :executable t)
govuk.css
View file @ 0aee118d
......@@ -38,3 +38,88 @@
.miniviz {
max-width: 100%;
}
.train-history-last {
margin-bottom: 20px !important;
}
.train-history-last .history-station {
background-color: #d53880;
color: white;
}
.train-history-last .history-content-mid {
margin-left: 0;
}
.history-dwell-tardy {
background-color: #d4351c;
font-weight: bold;
color: white;
padding: 0.4rem;
padding-top: 0.1rem;
padding-bottom: 0.1rem;
}
.history-station {
vertical-align: top;
margin-bottom: 0px !important;
padding: 0.4rem;
padding-top: 0.1rem;
padding-bottom: 0.1rem;
display: inline-block;
font-size: 1.5rem;
line-height: 1.25;
font-weight: 700;
}
.history-entry-time {
width: 4rem;
font-size: 1.5rem;
color: #505a5f;
padding-top: 0.1rem;
padding-bottom: 0.1rem;
padding-right: 0.4rem;
line-height: 1.25;
display: inline-block;
margin-right: 0.5rem;
}
.history-entry-time small {
vertical-align: top;
font-size: 1.1rem;
}
.history-station-platform {
display: inline-block;
float: right;
}
.history-transit {
color: darkgray;
font-style: italic;
}
.history-content-mid {
font-style: italic;
color: darkgray;
margin-left: 4rem;
display: inline-block;
padding-top: 0.4rem;
padding-bottom: 0.4rem;
}
.history-content-mid .govuk-tag {
font-style: normal;
}
.history-dest-change {
color: black;
}
.train-entry-arrow {
margin-right: 5px;
margin-left: 5px;
}
.history-transit-last {
font-style: normal;
color: #00703c;
font-weight: bold;
font-size: 1.5rem;
}
.history-dest {
background-color: #4c2c92;
font-weight: bold;
font-style: normal;
color: white;
padding: 0.4rem;
padding-top: 0.1rem;
padding-bottom: 0.1rem;
}
trackernet.lisp
View file @ 0aee118d
This diff is collapsed.
wobsite.lisp
View file @ 0aee118d
......@@ -129,6 +129,11 @@
<path fill=\"currentColor\" d=\"M0 0h13l20 20-20 20H0l20-20z\" />
</svg>")
(defparameter *govuk-go-arrow-standalone-svg*
"<svg class=\"train-entry-arrow\" xmlns=\"http://www.w3.org/2000/svg\" width=\"17.5\" height=\"19\" viewBox=\"0 0 33 40\" aria-hidden=\"true\" focusable=\"false\">)
<path fill=\"currentColor\" d=\"M0 0h13l20 20-20 20H0l20-20z\" />
</svg>")
(defparameter *govuk-go-arrow-small-svg*
"<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"8.75\" height=\"9.5\" viewBox=\"0 0 33 40\" aria-hidden=\"true\" focusable=\"false\">)
<path fill=\"currentColor\" d=\"M0 0h13l20 20-20 20H0l20-20z\" />
......@@ -171,7 +176,7 @@
(format nil
"~2,'0D:~2,'0D:~2,'0D" h m s)))
(defun mini-graphviz-stream (around-codes)
(defun mini-graphviz-stream (around-codes line-code)
(let* ((proc
(uiop:launch-program
'("dot" "-Tpng")
......@@ -183,7 +188,7 @@
(uiop:process-info-input proc)
:external-format :utf-8)))
(unwind-protect
(trackernet::write-mini-graphviz around-codes :out viz-in)
(trackernet::write-mini-graphviz around-codes line-code :out viz-in)
(close viz-in))
(uiop:process-info-output proc)))
......@@ -221,7 +226,7 @@
(hunchentoot:abort-request-handler "get a better hmac mate"))
(setf (hunchentoot:content-type*) "image/png")
(let* ((out (hunchentoot:send-headers))
(in (mini-graphviz-stream actual-around)))
(in (apply #'mini-graphviz-stream actual-around)))
(unwind-protect
(loop
for byte = (read-byte in nil nil)
......@@ -229,7 +234,225 @@
do (write-byte byte out))
(close in)))))
(defun display-trackernet-train (train &key code ts reporter distance show-dest maybe-hide-codes)
(defun format-duration (secs)
(if (> secs 60)
(format nil "~Am ~As" (floor secs 60) (rem secs 60))
(format nil "~As" secs)))
(defun universal-time-train2 (time)
(local-time:with-decoded-timestamp
(:sec s :minute m :hour h
:timezone trackernet::+europe-london-tz+)
(local-time:universal-to-timestamp time)
(format nil
"~2,'0D~2,'0D~A" h m
(cond
((>= s 45) "<small>¾</small>")
((>= s 30) "<small>½</small>")
((>= s 15) "<small>¼</small>")
(t "")))))
(defun track-codes-from-history-entries (ents)
(dolist (ent ents)
(when (typep ent 'trackernet::train-transit)
(return-from track-codes-from-history-entries
(trackernet::track-codes ent))))
nil)
(defun display-train-history-entry (ent line-code &key lastp)
(who:with-html-output-to-string (*standard-output* nil
:prologue nil)
(:li
:class (if lastp
"train-history-entry train-history-last"
"train-history-entry")
(when (typep ent 'trackernet::train-station-stop)
(who:htm
(:span
:class "history-entry-time"
(who:str (universal-time-train2
(trackernet::universal-ts ent))))))
(:span
:class (if (typep ent 'trackernet::train-station-stop)
"history-content-large" "history-content-mid")
(etypecase ent
(trackernet::train-destination-change
(who:htm
(:span
:class "history-dest-change"
(:strong
:class "history-dest"
(who:str (trackernet::destination ent)))
" is now this train's destination")))
(trackernet::train-station-stop
(who:htm
(:span
:class "history-station-stop"
(:strong
:class "history-station"
(when lastp
(who:str *govuk-go-arrow-standalone-svg*)
(who:str " "))
(who:str (trackernet::station-name ent)))
(:span
:class "history-station-platform"
(when (trackernet::platform ent)
(who:htm
(:span
:class "no-phones"
" plat. "
(:strong
:class "history-platform"
(who:str (trackernet::platform ent)))
" ")))
" for "
(:span
:class (concatenate
'string
"history-station-dwell "
(if (> (- (trackernet::end-ts ent)
(trackernet::universal-ts ent))
60)
"history-dwell-tardy"
""))
(who:esc (format-duration
(- (trackernet::end-ts ent)
(trackernet::universal-ts ent)))))))))
(trackernet::train-transit
(who:htm
(:span
:class "history-transit"
(when lastp
(who:htm
(:span
:class "history-transit-last"
(who:str *govuk-go-arrow-standalone-svg*)
" "
(who:esc (or
(cdr (assoc (first (trackernet::track-codes ent))
(cached-track-suggestions line-code)
:test #'string=))
(format nil "Location unknown (~A)"
(first (trackernet::track-codes ent)))))
" ")))
"in transit for "
(who:esc (format-duration
(- (trackernet::end-ts ent)
(trackernet::universal-ts ent)))))))
(trackernet::train-identity-change
(if (trackernet::wtt-id ent)
(let* ((class (if (trackernet::wtt-trip ent)
"govuk-tag govuk-tag--purple"
"govuk-tag govuk-tag--green")))
(who:htm
(:span
:class "history-ident-change"
"assigned timetable ID "
(:strong
:class class
(who:esc (trackernet::wtt-id ent))
(when (trackernet::wtt-trip ent)
(who:str " ×")
(who:esc (trackernet::wtt-trip ent)))))))
(who:htm
(:span
:class "history-ident-lost"
"lost timetable assignment")))))))))
(defun universal-time-as-wtt-time (time)
(local-time:with-decoded-timestamp
(:minute m :hour h
:timezone trackernet::+europe-london-tz+)
(local-time:universal-to-timestamp time)
(list h m)))
(defun universal-time-as-wtt-runs-when (time)
(local-time:with-decoded-timestamp
(:day-of-week dow
:timezone trackernet::+europe-london-tz+)
(local-time:universal-to-timestamp time)
(case dow
(0 :sundays)
(6 :saturdays)
(t :weekdays))))
(defun maybe-display-wtt-data (line-code wtt-id trip-no last-ts)
(unless (string= line-code "D")
(return-from maybe-display-wtt-data))
(alexandria:when-let*
((wtt-id (princ-to-string (parse-integer wtt-id)))
(runs-when (universal-time-as-wtt-runs-when last-ts))
(trip-no (ignore-errors (parse-integer trip-no)))
(timetable
(or
(when trip-no
(wtt::find-wtt-for wtt-id trip-no runs-when))
(wtt::find-wtt-for-time
wtt-id
(universal-time-as-wtt-time last-ts)
runs-when))))
(who:with-html-output-to-string (*standard-output* nil
:prologue nil)
(:details
:class "govuk-details"
(:summary
:class "govuk-details__summary"
(:span
:class "govuk-details__summary-text"
"View timetable "
(who:fmt "~A (run ~A)"
(wtt::train-no timetable)
(wtt::trip-no timetable))))
(:div
:class "govuk-details__text"
(:ul
:class "govuk-list"
(dolist (cpt (reverse (wtt::calling-points timetable)))
(destructuring-bind
(place-kwd h m s offset) cpt
(who:htm
(:li
:class "train-history-entry"
(:span
:class "history-entry-time"
(who:fmt "~2,'0D~2,'0D~A"
h m
(if (eql s 30)
"<small>½</small>"
"")))
(:span
:class "history-station-stop"
(:span
:class "history-station"
(who:fmt "~A" (wtt::print-wtt-keyword place-kwd)))
(when (> offset 0)
(who:htm
(:span
:class "history-station-platform"
(who:fmt "arrives ~A earlier"
(format-duration offset)))))))))))
(if (wtt::to-form timetable)
(who:htm
(:p
:class "govuk-body"
"This train's next service begins at "
(:strong
(who:fmt "~2,'0D~2,'0D"
(first (wtt::to-form timetable))
(second (wtt::to-form timetable))))
"."))
(who:htm
(:p
:class "govuk-body"
"This is the last timetable for this train.")))
(:p
:class "govuk-body"
"This information was sourced from page "
(:strong
(who:fmt "~D" (wtt::from-page timetable)))
" of the official Working Timetable."))))))
(defun display-trackernet-train (train line-code &key code ts reporter distance show-dest maybe-hide-codes)
(who:with-html-output-to-string (*standard-output* nil
:prologue nil)
(:tr
......@@ -276,7 +499,7 @@
(:span
(who:esc (or
(cdr (assoc (trackernet::track-code train)
(cached-track-suggestions "D")
(cached-track-suggestions line-code)
:test #'string=))
(trackernet::location-desc train)
"<somewhere>"))
......@@ -295,7 +518,7 @@
(who:htm
(:a
:class "govuk-link"
:href (format nil "/train?train=~A"
:href (format nil "/train2?train=~A"
code)
"[more]")
(who:str " ")))
......@@ -315,7 +538,9 @@
"Stale")))
(:a
:href (multiple-value-bind (around hmac)
(trusted-serialize (list (trackernet::track-code train)))
(trusted-serialize (list
(list (trackernet::track-code train))
line-code))
(format nil "/miniviz?around=~A&hmac=~A"
(hunchentoot:url-encode
around)
......@@ -328,6 +553,128 @@
(defparameter *max-train-lines* 100)
(hunchentoot:define-easy-handler (train-simple :uri "/train2") (train)
(when (< (length train) #.(length "X-train-Y"))
(setf (hunchentoot:return-code*) 400)
(hunchentoot:abort-request-handler
(format nil "bad train id mate: ~A" train)))
(unless (red:exists train)
(alexandria:when-let ((new-train (red:get (format nil "rescue-ptr-~A" train))))
;; train got rescued into another train
(hunchentoot:redirect (format nil "/train2?train=~A" new-train)))
(setf (hunchentoot:return-code*) 404)
(hunchentoot:abort-request-handler "not found lol"))
(let* ((line-code (subseq train 0 1))
(line-data (tube-line-by-code line-code))
(last-train-data (second (trackernet::redis-last-cpk train)))
(last-ts (trackernet::redis-last-score train))
(wtt-id (trackernet::nilify-zeros (trackernet::set-no last-train-data)))
(trip-no (trackernet::nilify-zeros (trackernet::trip-no last-train-data)))
(secs-new (- (get-universal-time) (trackernet::redis-first-score train)))
(secs-old (- (get-universal-time) last-ts))
(train-data (trackernet::make-train-history
train
:cached-descriptions (cached-track-suggestions line-code)))
(viz-data (multiple-value-list
(trusted-serialize
(list
(track-codes-from-history-entries train-data)
line-code))))
(first t)
(*accent-colour* (apply #'html-rgb-colour (third line-data))))
(render ()
(:a
:class "govuk-back-link"
:href (format nil "/line?code=~A"
line-code)
(who:fmt "~A line"
(first line-data)))
(:span
:class "govuk-caption-xl"
"Train history for "
(:span
:class "id-field"
(who:str train)))
(:h1
:class "govuk-heading-xl"
(who:fmt "Train to ~A "
(or
(trackernet::destination-desc
last-train-data)
"nowhere")))
(when (< secs-new 45)
(who:htm
(:div
:class "govuk-warning-text"
(:span
:class "govuk-warning-text__icon"
"!")
(:strong
:class "govuk-warning-text__text"
"This train might be missing data. Please wait a few moments while we attempt to find more history."))))
(cond
((> secs-old 120)
(who:htm
(:div
:class "govuk-warning-text"
(:span
:class "govuk-warning-text__icon"
"!")
(:strong
:class "govuk-warning-text__text"
"We seem to have lost track of this train, due to gaps in our open data sources."))))
((> secs-old 15)
(who:htm
(:div
:class "govuk-warning-text"
(:span
:class "govuk-warning-text__icon"
"!")
(:strong
:class "govuk-warning-text__text"
"This train's data is currently delayed by about a minute.")))))
(when wtt-id
(alexandria:when-let
((wd (maybe-display-wtt-data
line-code
wtt-id
trip-no
last-ts)))
(who:str wd)))
(:details
:class "govuk-details"
(:summary
:class "govuk-details__summary"
(:span
:class "govuk-details__summary-text"
"Details for nerds"))
(:div
:class "govuk-details__text"
(:p
:class "govuk-body"
"Track code graph (shows intertube's view of the network):")
(:img
:class "miniviz"
:src (format nil "/miniviz?around=~A&hmac=~A"
(hunchentoot:url-encode
(car viz-data))
(hunchentoot:url-encode
(cadr viz-data))))
(:p
:class "govuk-body"
"View "
(:a
:class "govuk-link"
:href (format nil "/train?train=~A" train)
"the raw Trackernet data")
" for more granular information.")))
(:ul
:class "govuk-list"
(dolist (ent train-data)
(who:str (display-train-history-entry ent line-code :lastp first))
(when first
(setf first nil)))))))
(hunchentoot:define-easy-handler (train :uri "/train") (train limit)
(when limit
(unless (setf limit (ignore-errors (parse-integer limit)))
......@@ -352,7 +699,11 @@
(last-train-obj (third (car (last train-data))))
(last-track-code (trackernet::track-code last-train-obj))
(secs-old (- (get-universal-time) (trackernet::redis-last-score train)))
(viz-data (multiple-value-list (trusted-serialize (list last-track-code))))
(viz-data (multiple-value-list
(trusted-serialize
(list
(list last-track-code)
line-code))))
(max-to-show (min train-data-len
(or limit *max-train-lines*)))
(lcids '())
......@@ -478,6 +829,7 @@
(equal last (trackernet::track-code train))
(>= i max-to-show))
do (who:str (display-trackernet-train train
line-code
:ts ts
:show-dest (not (string= (trackernet::destination-desc train) last-dest))
:reporter reporter))
......@@ -503,6 +855,9 @@
(defun trains-by-dijkstra-from (linecode trackcode)
"Returns a sorted list of (DISTANCE TRAIN-ID TRAIN) lists for all trains on the given line (LINECODE), ordered by their Dijkstra-determined distance from the given TRACKCODE."
(let* ((objects (train-objects-on-line linecode))
(trackernet::*normalized-track-links*
(gethash linecode
trackernet::*per-line-track-graph*))
(distanced-objects
(mapcar
(lambda (tlist)
......@@ -618,6 +973,7 @@
(loop
for (distance key train) in train-list
do (who:str (display-trackernet-train train
linecode
:distance distance
:maybe-hide-codes t
:show-dest t
......@@ -801,7 +1157,7 @@
for (key reporter train) in (sort trains #'string<
:key (lambda (trn)
(trackernet::train-id (third trn))))
do (who:str (display-trackernet-train train :code key)))))))))))
do (who:str (display-trackernet-train train code :code key)))))))))))
(hunchentoot:define-easy-handler (root :uri "/") ()
(render ()
......
wtt.lisp 0 → 100644
View file @ 0aee118d
(defpackage :wtt
(:use :cl))
(in-package :wtt)
(defparameter *wtt-district* "/home/eta/Downloads/wtt-151-dis.pdf")
(defun run-pdftotext (timetable page x y width height)
"Runs pdftotext to extract data from PAGE of TIMETABLE, with a bounding box starting at (X, Y) with dimensions (WIDTH, HEIGHT)."
(split-sequence:split-sequence
#\Newline
(string-trim
'(#\Space #\Return #\Newline #\Tab)
(uiop:run-program
`("pdftotext" "-r" "300"
"-f" ,(princ-to-string page)
"-l" ,(princ-to-string page)
"-x" ,(princ-to-string x)
"-y" ,(princ-to-string y)
"-W" ,(princ-to-string width)
"-H" ,(princ-to-string height)
"-nopgbrk"
,timetable
"-")
:error-output *error-output*
:output :string))))
(defun run-pdftotext-with-bbox (timetable page bbox)
(apply #'run-pdftotext (append (list timetable page) bbox)))
(defparameter *header-left-bbox* '(148 190 854 97))
(defparameter *header-right-bbox* '(1475 187 854 97))
(defparameter *train-data-top-y* 300)
(defparameter *train-data-bottom-y* 1820)
(defparameter *train-data-x* 548)
(defparameter *train-data-width* 90)
(defparameter *train-data-per-row* 20)
(defparameter *train-no-delta* 63)
(defparameter *train-no-delta* 63)
(defparameter *deltas* nil)
(defun read-one-train (timetable page n &optional bottom)
(let ((x (+ *train-data-x*
(* n *train-data-width*)))
(y (if bottom
*train-data-bottom-y*
*train-data-top-y*)))
(loop
for (keyword . y-delta) in *deltas*
append (list
(cons keyword
(run-pdftotext timetable page x y *train-data-width* y-delta)))
do (incf y y-delta))))
(defparameter *deltas-eastbound*
'((:train-no . 63)
(:trip-no . 49)
(:notes . 97)
(:eby-pfm . 35)
(:eby . 25)
(:eac . 25)
(:eac-depot . 25)
(:acton-town . 35)
(:richmond . 35)
(:turnham-green . 25)
(:hammersmith . 25)
(:west-kensington . 38)
(:olympia . 49)
(:wimbledon . 35)
(:east-putney . 25)
(:putney-bridge . 25)
(:parsons-green . 25)
(:earls-court . 25)
(:earls-court-pfm . 35)
(:hsk . 35)
(:hsk-pfm . 25)
(:edgware-road . 25)
(:edgware-road-pfm . 35)
(:hsk-inner-rail . 35)
(:gloucester-road . 25)
(:south-kensington . 25)
(:embankment . 25)
(:mansion-house . 25)
(:tower-hill . 25)
(:aldgate . 35)
(:liverpool-street . 35)
(:aldgate-east . 25)
(:whitechapel . 25)
(:west-ham . 35)
(:plaistow . 35)
(:barking . 25)
(:barking-sidings . 25)
(:dagenham-east . 25)
(:upminster . 25)
(:upminster-pfm . 25)
(:upminster-depot . 60)
(:to-form . 60)))
(defparameter *deltas-westbound*
'((:train-no . 63)
(:trip-no . 49)
(:notes . 97)
(:upminster-depot . 35)
(:upminster-pfm . 25)
(:upminster . 25)
(:dagenham-east . 25)
(:barking-sidings . 25)
(:barking . 25)
(:plaistow . 35)
(:west-ham . 35)
(:whitechapel . 25)
(:aldgate-east . 25)
(:liverpool-street . 35)
(:aldgate . 35)
(:tower-hill . 25)
(:mansion-house . 25)
(:embankment . 25)
(:south-kensington . 25)
(:gloucester-road-pfm-1 . 25)
(:gloucester-road-pfm-2 . 25)
(:hsk-outer-rail . 35)
(:edgware-road-pfm . 35)
(:edgware-road . 25)
(:hsk-pfm . 25)
(:hsk . 35)
(:earls-court-pfm . 35)
(:earls-court . 25)
(:parsons-green . 25)
(:putney-bridge . 25)
(:east-putney . 25)
(:wimbledon . 35)
(:olympia . 49)
(:west-kensington . 38)
(:hammersmith . 25)
(:turnham-green . 25)
(:richmond . 35)
(:acton-town . 35)
(:eac-depot . 25)
(:eac . 25)
(:eby . 25)
(:eby-pfm . 60)
(:to-form . 45)))
(defun print-wtt-keyword (kwd)
(case kwd
(:eby "Ealing Broadway")
(:eac "Ealing Common")
(:eac-depot "Ealing Common Depot")
(:acton-town "Acton Town")
(:richmond "Richmond")
(:turnham-green "Turnham Green")
(:hammersmith "Hammersmith")
(:west-kensington "West Kensington")
(:olympia "Olympia")
(:wimbledon "Wimbledon")
(:east-putney "East Putney")
(:putney-bridge "Putney Bridge")
(:parsons-green "Parsons Green")
(:earls-court "Earl's Court")
(:hsk "High Street Kensington")
(:edgware-road "Edgware Road")
(:hsk-inner-rail "High Street Kensington")
(:gloucester-road "Gloucester Road")
(:gloucester-road-pfm-1 "Gloucester Road")
(:south-kensington "South Kensington")
(:embankment "Embankment")
(:mansion-house "Mansion House")
(:tower-hill "Tower Hill")
(:aldgate "Aldgate")
(:liverpool-street "Liverpool Street")
(:aldgate-east "Aldgate East")
(:whitechapel "Whitechapel")
(:west-ham "West Ham")
(:plaistow "Plaistow")
(:barking "Barking")
(:barking-sidings "Barking Sidings")
(:dagenham-east "Dagenham East")
(:upminster "Upminster")
(:upminster-depot "Upminster Depot")
(t (princ-to-string kwd))))
(defun read-one-page (timetable page)
(let* ((header-left (run-pdftotext-with-bbox timetable page *header-left-bbox*))
(header-right (run-pdftotext-with-bbox timetable page *header-right-bbox*))
(*deltas* (if (search "EASTBOUND" (first header-left))
*deltas-eastbound*
*deltas-westbound*)))
(append
(list page header-left header-right)
(loop
for col from 0 below *train-data-per-row*
append (list (read-one-train timetable page col)))
(loop
for col from 0 below *train-data-per-row*
append (list (read-one-train timetable page col t))))))
(defun main ()
(loop
for page from 19 upto 160
do (format t "~&Processing page ~A~%" page)
(cpk:encode-to-file
(read-one-page "./wtt-district.pdf" page)
(format nil "./wtt-district-~A.cpk" page))))
(defvar *wtt-data* '())
(defun convert-abbreviation-to-offset (abbrev)
(ecase (elt abbrev 0)
(#\a 30)
(#\b 60)
(#\c 90)
(#\d 120)
(#\e 150)
(#\f 180)
(#\g 210)
(#\h 240)
(#\j 270)
(#\k 300)
(#\T 0)
(#\Space 0)))
(defclass wtt-train ()
((train-no
:initarg :train-no
:reader train-no)
(trip-no
:initarg :trip-no
:reader trip-no)
(notes
:initarg :notes
:reader notes)
(calling-points
:initarg :calling-points
:reader calling-points)
(to-form
:initarg :to-form
:reader to-form)
(from-page
:initarg :from-page
:reader from-page)
(runs-when
:initarg :runs-when
:reader runs-when)))
(defmethod print-object ((obj wtt-train) stream)
(print-unreadable-object (obj stream :type t)
(with-slots (train-no trip-no notes calling-points to-form from-page runs-when) obj
(format stream "~A×~A~@[ (notes: ~{~A~^, ~})~] runs ~A with ~A stops (first ~2,'0D~2,'0D at ~A), forms ~2,'0D~2,'0D (src p#~A)"
train-no trip-no notes runs-when (length calling-points)
(second (first calling-points)) (third (first calling-points))
(first (first calling-points))
(first to-form) (second to-form)
from-page))))
(defun parse-wtt-time (timestr)
(cl-ppcre:register-groups-bind (h abbrevs m halves)
("(\\d\\d)\\s*([abcdefghjkT ])?\\s*(\\d\\d)(.*)" timestr)
(let* ((h (parse-integer h))
(m (parse-integer m))
(offset (convert-abbreviation-to-offset (or abbrevs " ")))
(is-half (or
(and
(position #\1 halves)
(position #\2 halves))
(position #\1 halves))))
(list h m (if is-half 30 0) offset))))
(defvar *wtt-hash-table* (make-hash-table :test #'equal))
(defun strconcat (a b)
(concatenate 'string a b))
(defun parse-wtt-train-from-list (lst &key runs-when from-page)
(let ((train-no)
(trip-no)
(notes)
(to-form)
(calling-points))
(dolist (pair lst)
(let ((values (reduce #'strconcat (cdr pair))))
(case (car pair)
(:train-no
(setf train-no values))
(:trip-no
(setf trip-no (parse-integer values)))
(:to-form
(setf to-form (parse-wtt-time values)))
(:notes
(setf notes (delete-if
(lambda (x) (eql (length x) 0))
(cdr pair))))
(otherwise
(alexandria:when-let
((time (ignore-errors (parse-wtt-time values))))
(push (cons (car pair) time) calling-points))))))
(unless (and train-no trip-no calling-points)
(error "Train is missing data; ~Ax~A #cpts ~A"
train-no trip-no (length calling-points)))
(make-instance 'wtt-train
:train-no train-no
:trip-no trip-no
:notes notes
:to-form to-form
:runs-when runs-when
:from-page from-page
:calling-points (nreverse calling-points))))
(defun headers-to-runtime (header-left header-right)
(let ((total-string
(reduce #'strconcat
(reduce #'append (list header-left header-right)))))
(cond
((search "MONDAY" total-string)
:weekdays)
((search "SATURDAY" total-string)
:saturdays)
((search "SUNDAY" total-string)
:sundays)
(t
(error "Unknown headers ~A" total-string)))))
(defun add-wtt-page-to-table (page)
(destructuring-bind
(page-no header-left header-right &rest trains)
page
(format t "~&processing page #~A: ~A — ~A (~A trains)~%"
page-no header-left header-right (length trains))
(let ((runs-when (headers-to-runtime header-left header-right)))
(dolist (trn trains)
(handler-case
(let* ((wtt-train (parse-wtt-train-from-list
trn
:runs-when runs-when
:from-page page-no))
(train-no
(string-trim
'(#\D #\E #\W)
(train-no wtt-train))))
(setf (gethash train-no *wtt-hash-table*)
(cons wtt-train
(gethash train-no *wtt-hash-table*))))
(error (e)
(warn "Failed to parse train: ~A" e)))))))
(defun add-wtt-pages-to-table (pages-list)
(dolist (page pages-list)
(with-simple-restart (continue "Skip this page and continue.")
(add-wtt-page-to-table
(car
(cpk:decode-file page))))))
(defun import-wtt-pages (pages-list)
(clrhash *wtt-hash-table*)
(add-wtt-pages-to-table pages-list)
(loop
for train-no being the hash-keys of *wtt-hash-table*
do (setf (gethash train-no *wtt-hash-table*)
(sort
(gethash train-no *wtt-hash-table*)
#'<
:key #'trip-no)))
(hash-table-count *wtt-hash-table*))
(defun find-wtt-for (train-no trip-no runs-when)
(alexandria:when-let
((trains (gethash train-no *wtt-hash-table*)))
(find-if
(lambda (trn)
(and
(eql (trip-no trn) trip-no)
(eql (runs-when trn) runs-when)))
trains)))
(defun time-compare (timea timeb func)
(funcall func
(+ (* (first timea) 60)
(second timea))
(+ (* (first timeb) 60)
(second timeb))))
(defun find-wtt-for-time (train-no time runs-when)
(alexandria:when-let
((trains (gethash train-no *wtt-hash-table*)))
(find-if
(lambda (trn)
(and
(eql (runs-when trn) runs-when)
(time-compare
(cdr (first (calling-points trn)))
time
#'<=)
(time-compare
(cdr (car (last (calling-points trn))))
time
#'>=)))
trains)))