Compare commits

...

5 Commits

  1. 2
      deploy.txt
  2. 85
      govuk.css
  3. 467
      trackernet.lisp
  4. 374
      wobsite.lisp
  5. 396
      wtt.lisp

2
deploy.txt

@ -1,7 +1,7 @@
(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)

85
govuk.css

@ -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;
}

467
trackernet.lisp

@ -14,12 +14,13 @@
(defparameter *trackernet-scrape-interval* 4)
(defparameter *prediction-expiry-secs* 60)
(defparameter *train-active-expiry-secs* 30)
(defparameter *rescue-grace-period-secs* 15)
(defparameter *train-active-expiry-secs-real* 360)
(defparameter *train-set-code-expiry-secs* 360)
(defparameter *track-code-expiry-secs* 10)
(defparameter *rude-requests-per-minute* 300)
(defparameter *train-live-data-limit* 10000)
(defparameter *rescue-max-dist* 8.0)
(defparameter *train-live-data-limit* 40000)
(defparameter *rescue-max-dist* 10.0)
(defparameter *rescue-timediff-threshold* -15)
(defparameter *codes-to-scrape*
'(("D" "UPM") ; Upminster (terminus)
@ -60,14 +61,20 @@
("TDR.PBLA" "TD834")
("TD844B.A" "TD844C")
("TD846B" "TD844B.A")))
(defparameter *per-line-track-graph*
(alexandria:alist-hash-table
(mapcar
(lambda (pair)
(cons (car pair)
(alexandria:alist-hash-table
(car (cpk:decode-file (cadr pair)))
:test 'equal)))
'(("D" "./normalized-track-links.cpk")
("J" "./2021-04-19-jubilee-1.cpk")
("V" "./2021-04-19-victoria-1.cpk")))
:test 'equal))
(defparameter *normalized-track-links*
(or
(ignore-errors
(alexandria:alist-hash-table
(car
(cpk:decode-file "./normalized-track-links.cpk"))
:test 'equal))
(make-hash-table :test 'equal)))
(make-hash-table :test 'equal))
(defparameter +manual-count+ 999999)
(defvar *current-prediction* nil)
@ -235,6 +242,19 @@
departed direction is-stalled track-code line input-dest
leading-car-no)
(conspack:define-index trackernet-cpk-v1
;; trackernet-train
train-id lcid set-no trip-no seconds-to time-to location-desc
destination-desc dest-code order depart-time depart-interval
departed direction is-stalled track-code line input-dest
leading-car-no
;; trackernet-platform
name num next-train trains
;; trackernet-station
code cur-time platforms
;; trackernet-prediction
created-ts line-code line-name stations)
(defmethod print-object ((obj trackernet-prediction) stream)
(print-unreadable-object (obj stream :type t)
(with-slots (line-name line-code created-ts stations) obj
@ -483,11 +503,13 @@
universal-ts))))
(defun cpk-base64 (object)
(qbase64:encode-bytes
(cpk:encode object)))
(cpk:with-named-index 'trackernet-cpk-v1
(qbase64:encode-bytes
(cpk:encode object))))
(defun cpk-unbase64 (data)
(cpk:decode (subseq (qbase64:decode-string data) 0)))
(cpk:with-named-index 'trackernet-cpk-v1
(cpk:decode (subseq (qbase64:decode-string data) 0))))
(defun get-all (pattern)
"Calls RED:SCAN in a loop, returning all the Redis keys matching PATTERN."
@ -526,6 +548,13 @@
(when data
(cpk-unbase64 data))))
(defun redis-paired-mget (key-names)
"Given a list of KEY-NAMES, returns an alist of each name paired with its value, or NIL if the value did not exist."
(loop
for key in key-names
for value in (apply #'red:mget key-names)
collect (cons key value)))
(defun redis-cpk-sorted-set-all (key)
"Gets all elements of the sorted set KEY, alongside their scores, CONSPACK-decoding each element."
(let ((data
@ -541,15 +570,18 @@
(defun redis-sorted-set-length (key)
(red:zcount key "-inf" "+inf"))
(defun nilify-zeros (str)
"If STR is not NIL and contains nothing or only zeroes, return NIL; otherwise, return STR."
(when (and str
(> (length (string-trim '(#\0) str)) 0))
str))
(defun redis-train (universal-ts line-code code-station train)
(with-slots (train-id set-no trip-no lcid seconds-to track-code location-desc leading-car-no) train
(when (and (or lcid train-id) seconds-to track-code)
(let* ((tid (or (if (and lcid (or (string= lcid "0")
(string= lcid "")))
nil
lcid)
(format nil "tid~A" train-id)))
(key (format nil "~A-train-~A" line-code tid)))
(let* ((lcid (nilify-zeros lcid))
(tid (or lcid (format nil "tid~A" train-id)))
(key (or (format nil "~A-train-~A" line-code tid))))
;; get a mapping of seconds to -> track code
(red:zadd (format nil "~A-secs-to-track-code"
code-station)
@ -559,9 +591,9 @@
(when (and location-desc
;; this is highly annoying
(not (string= location-desc "At Platform")))
(red:set (format nil "~A-track-desc-~A"
line-code track-code)
location-desc))
(red:setnx (format nil "~A-track-desc-~A"
line-code track-code)
location-desc))
;; add this train into the new list of trains for
;; the station
(red:sadd (format nil "~A-trains-new" code-station) key)
@ -571,9 +603,12 @@
(bgcol :green) key (colreset) code-station train)
(statsd-inc "intertube.new")
;; make a rescuable thingy
;; (see the note inside GET-RESCUABLE-TRAINS for more)
(red:setex (format nil "~A-rescue-~A"
line-code tid)
*train-active-expiry-secs-real*
(+ *train-active-expiry-secs*
*rescue-grace-period-secs*
*train-active-expiry-secs-real*)
track-code))
;; mark this train as active
(red:setex (format nil "~A-active-~A"
@ -586,7 +621,11 @@
universal-ts
;; include the station the train is from
;; for things like secondsto
(cpk-base64 (list code-station train)))))))
;; also include some random data, to minimize
;; the chance that this element is the same as some
;; previous element and redis scronches stuff
(cpk-base64 (list (format nil "~A-~A" code-station (random 256))
train)))))))
(defun maybe-redis-trackernet-prediction (pred)
(multiple-value-bind (filename universal-ts)
@ -609,12 +648,12 @@
(length (get-trains pred)))))))
(defun get-archivable-trains ()
"Returns a list of all trains that were last updated more than *TRAIN-ACTIVE-EXPIRY-SECS* ago."
"Returns a list of all trains that were last updated more than *TRAIN-ACTIVE-EXPIRY-SECS* ago, or have too many records."
(let* ((trains (get-all "?-train-*"))
(cutoff (- (get-universal-time) *train-active-expiry-secs*)))
(delete-if-not (lambda (train)
(and
(< (redis-sorted-set-length train)
(or
(> (redis-sorted-set-length train)
*train-live-data-limit*)
(< (redis-last-score train) cutoff)))
trains)))
@ -648,10 +687,11 @@
(defun conspack-encode-to-archive (archive name data)
"Encode DATA into ARCHIVE in CONSPACK format, using the given NAME as filename."
(let* ((data (cpk:encode data))
(stream (flexi-streams:make-in-memory-input-stream data))
(header (make-fake-archive-entry name (length data))))
(archive:write-entry-to-archive archive header :stream stream)))
(cpk:with-named-index 'trackernet-cpk-v1
(let* ((data (cpk:encode data))
(stream (flexi-streams:make-in-memory-input-stream data))
(header (make-fake-archive-entry name (length data))))
(archive:write-entry-to-archive archive header :stream stream))))
(defun maybe-zstd-last-archive ()
"Runs `zstd` blocking-ly on yesterday's tar archive, if it exists."
@ -677,17 +717,34 @@
(red:set (format nil "rescue-ptr-~A"
to-be-archived)
new-train)
(red:del
(format nil "~A-rescue-~A"
(subseq new-train 0 1)
(subseq new-train #.(length "X-train-"))))
(loop
for (ts . data) in (redis-cpk-sorted-set-all to-be-archived)
do (red:zadd new-train ts (cpk-base64 data))))
(defun get-rescuable-trains (line-code)
"Gets rescuable trains for the given LINE-CODE, i.e. trains that were created recently that could be joined onto the end of stale trains."
(mapcar
(lambda (x)
(cons
(format nil "~A-train-~A" line-code (subseq x #.(length "D-rescue-")))
(red:get x)))
(get-all (format nil "~A-rescue-*" line-code))))
(format nil "~A-train-~A" line-code (subseq (car x) #.(length "D-rescue-")))
(cdr x)))
(redis-paired-mget
(delete-if
(lambda (x)
;; This is kind of subtle: to prevent old trains screwing up
;; the rescue of new trains, we add a grace period to the TTL
;; of the rescue key that's the length of time it takes for
;; an active train to become inactive (plus a few seconds).
;;
;; This means that an old train can't snatch new trains until
;; trains that could conceivably have just expired and be
;; the most likely candidate have had their go.
(> (red:ttl x) *train-active-expiry-secs-real*))
(get-all (format nil "~A-rescue-*" line-code))))))
(defun get-dijkstra-path (previous-table goal)
(nreverse
@ -741,7 +798,8 @@
(list goal))))
(defun find-rescuable-train-dijkstra (start line-code &key stop-after-dist)
(when (string= line-code "D")
(alexandria:when-let ((*normalized-track-links*
(gethash line-code *per-line-track-graph*)))
(let ((rescuable (get-rescuable-trains line-code)))
(mapcar
(lambda (train-and-code)
@ -755,7 +813,7 @@
"Formats a rescue path, putting -> arrows between codes."
(format nil "~{~A~^ -> ~}" rescue-path))
(defun maybe-rescue-train (key)
(defun maybe-rescue-train (key &key just-return-distance)
"Figure out whether the train with key KEY can be rescued. If it can, rescue it, returning (VALUES NEW-CODE DISTANCE CODE-PATH)."
(let* ((last-data (cadr (redis-last-cpk key)))
(last-ts (redis-last-score key))
@ -769,6 +827,8 @@
:key #'cadr)))
(dolist (candidate rescue-candidates)
(destructuring-bind (new-code distance code-path) candidate
(when just-return-distance
(return-from maybe-rescue-train distance))
;; if this and future candidates are above the max dist, stop
;; considering candidates
(when (> distance *rescue-max-dist*)
@ -815,6 +875,7 @@
(red:incr (format nil "~A-code-archives-~A"
line-code (track-code last-data)))
(statsd-inc "intertube.archived")
(statsd-counter "intertube.archived-records" records-archived)
(conspack-encode-to-archive tar-out filename archive-data)
(red:del key)
(values records-archived last-data unique-track-code-count)))
@ -833,7 +894,6 @@
(if (and (> (redis-last-score key)
(- (get-universal-time) *train-active-expiry-secs-real*))
(< (redis-sorted-set-length key) *train-live-data-limit*)
(string= (subseq key 0 1) "D")
(not archive-all))
(multiple-value-bind (new-code dist path timediff)
(maybe-rescue-train key)
@ -856,9 +916,10 @@
(sort
(mapcar
(lambda (key)
(cons (subseq key #.(length "D-code-archives-"))
(parse-integer (red:get key))))
(get-all (format nil "~A-code-archives-*" line-code)))
(cons (subseq (car key) #.(length "D-code-archives-"))
(parse-integer (cdr key))))
(redis-paired-mget
(get-all (format nil "~A-code-archives-*" line-code))))
#'>
:key #'cdr))
@ -905,7 +966,8 @@
func
(cons
filename
(cpk:decode data))))))))))))
(cpk:with-named-index 'trackernet-cpk-v1
(cpk:decode data)))))))))))))
(defun scraper-loop (line-code station-code)
"Scrape the station with the given codes every *TRACKERNET-SCRAPE-INTERVAL* in a loop, calling MAYBE-WRITE-TRACKERNET-PREDICTION with each scrape result.
@ -946,6 +1008,18 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
(get-all (format nil "~A-active-*"
line-code)))
(defun old-active-keys (line-code)
(delete-if #'red:get (trains-active-on-line line-code)))
(defun all-trains-with-sizes ()
(sort
(mapcar
(lambda (trn)
(cons trn (redis-sorted-set-length trn)))
(get-all "?-train-*"))
#'>
:key #'cdr))
(defun statsd-reporter-loop (line-code)
(redis:with-connection ()
(loop
@ -958,10 +1032,15 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
"Archive all trains that have expired."
(let ((trains (get-archivable-trains)))
(unless (null trains)
;; sort the trains earliest-to-latest,
;; so rescue chaining has a chance of working
(sort trains #'<
:key #'redis-last-score)
;; sort trains in order of smallest rescue distance, to avoid
;; faraway trains screwing up closer trains
(setf trains (sort trains #'<
:key (lambda (trn)
(or
(maybe-rescue-train
trn
:just-return-distance t)
sb-ext:double-float-positive-infinity))))
(statsd-gauge "intertube.maybe-archivable" (length trains))
(handler-case
(archive-trains-tar trains)
@ -998,8 +1077,6 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
(length codes))))
(when (> rpm *rude-requests-per-minute*)
(error "~A requests/min is a bit rude" rpm))
(log:info "~A nodes in normalized track graph"
(hash-table-size *normalized-track-links*))
(log:info "starting ~A scrapers, ~A requests/min..."
(length codes) rpm))
(setf *trackernet-kill-switch* nil)
@ -1037,10 +1114,11 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
"Returns an alist of all track codes and their textual descriptions for the given LINE-CODE."
(mapcar
(lambda (key)
(cons (subseq key #.(length "X-track-desc-"))
(red:get key)))
(get-all (format nil "~A-track-desc-*"
line-code))))
(cons (subseq (car key) #.(length "X-track-desc-"))
(cdr key)))
(redis-paired-mget
(get-all (format nil "~A-track-desc-*"
line-code)))))
(defun reset-track-links-set ()
(setf *track-links-set* (make-hash-table
@ -1115,72 +1193,78 @@ Stop if *TRACKERNET-KILL-SWITCH* is set to T."
(cpk:encode (alexandria:hash-table-alist *normalized-track-links*)
:stream stream)))
(defun write-mini-graphviz (around-codes &key (out *standard-output*) (neato nil))
(defun write-mini-graphviz (around-codes line-code &key (out *standard-output*) (neato nil))
"Write out a mini graph containing the nodes around AROUND-CODE in graphviz format."
(princ "digraph {" out)
(terpri out)
(princ "node [shape=box margin=\"0.1,0.1\"];" out)
(terpri out)
(if neato
(progn
(princ "layout = \"neato\";" out)
(terpri out))
(progn
(princ "rankdir = LR;" out)
(terpri out)))
(let ((nodes around-codes)
(nodes-1 '())
(links '()))
(loop
for src being the hash-keys of *normalized-track-links*
using (hash-value dests)
when (member src around-codes :test #'string=)
do (dolist (dest dests)
(pushnew (car dest) nodes
:test #'string=)
(push (list src (car dest) (cadr dest))
links))
unless (member src around-codes :test #'string=)
do (loop
for (dest dist) in dests
when (member dest around-codes :test #'string=)
do (pushnew src nodes
:test #'string=)
when (member dest around-codes :test #'string=)
do (push
(list src dest dist)
links)))
(setf nodes-1 (copy-seq nodes))
(loop
for src being the hash-keys of *normalized-track-links*
using (hash-value dests)
when (and (member src nodes-1 :test #'string=)
(not (member src around-codes :test #'string=)))
do (dolist (dest dests)
(unless (member (car dest) around-codes :test #'string=)
(let ((*normalized-track-links*
(gethash line-code *per-line-track-graph*)))
(princ "digraph {" out)
(terpri out)
(princ "node [shape=box margin=\"0.1,0.1\"];" out)
(terpri out)
(if neato
(progn
(princ "layout = \"neato\";" out)
(terpri out))
(progn
(princ "rankdir = LR;" out)
(terpri out)))
(let ((nodes around-codes)
(nodes-1 '())
(links '()))
(loop
for src being the hash-keys of *normalized-track-links*
using (hash-value dests)
when (member src around-codes :test #'string=)
do (dolist (dest dests)
(pushnew (car dest) nodes
:test #'string=)
:test #'string=)
(push (list src (car dest) (cadr dest))
links))))
(loop
with value
for node in nodes
do (setf value (red:get (format nil "D-track-desc-~A" node)))
do (format out "\"~A\" [fillcolor=~A style=filled label=<<B>~A</B><BR /><I><FONT POINT-SIZE=\"10\">~{~A~^<BR ALIGN=\"LEFT\"/>~}</FONT></I>>]~%"
node
(if (member node around-codes :test #'string=)
"lightblue1"
"white")
node
(if (eql (length value) 0)
'("???")
(bobbin:wrap (list value) 20))))
(loop
for (src dest dist) in links
do (format out "\"~A\" -> \"~A\" [len=~F];~%"
src dest dist))
(princ "}" out)
(terpri out)))
links))
unless (member src around-codes :test #'string=)
do (loop
for (dest dist) in dests
when (member dest around-codes :test #'string=)
do (pushnew src nodes
:test #'string=)
when (member dest around-codes :test #'string=)
do (push
(list src dest dist)
links)))
(setf nodes-1 (copy-seq nodes))
(loop
for src being the hash-keys of *normalized-track-links*
using (hash-value dests)
when (and (member src nodes-1 :test #'string=)
(not (member src around-codes :test #'string=)))
do (dolist (dest dests)
(unless (member (car dest) around-codes :test #'string=)
(pushnew (car dest) nodes
:test #'string=)
(push (list src (car dest) (cadr dest))
links))))
(loop
for node in nodes
for (nil . value) in (redis-paired-mget
(mapcar
(lambda (node)
(format nil "~A-track-desc-~A"
line-code node))
nodes))
do (format out "\"~A\" [fillcolor=~A style=filled label=<<B>~A</B><BR /><I><FONT POINT-SIZE=\"10\">~{~A~^<BR ALIGN=\"LEFT\"/>~}</FONT></I>>]~%"
node
(if (member node around-codes :test #'string=)
"lightblue1"
"white")
node
(if (eql (length value) 0)
'("???")
(bobbin:wrap (list value) 20))))
(loop
for (src dest dist) in links
do (format out "\"~A\" -> \"~A\" [len=~F];~%"
src dest dist))
(princ "}" out)
(terpri out))))
(defun write-track-links-graphviz (&key (out *standard-output*) (cutoff 20))
"Write the track links out in graphviz format."
@ -1190,9 +1274,8 @@ layout = \"neato\";")
(terpri out)
(format *debug-io* "*** Writing track descriptions~%")
(loop
for key in (get-all "D-track-desc-*")
for (key . value) in (redis-paired-mget (get-all "J-track-desc-*"))
for actual = (subseq key 13)
for value = (red:get key)
do (format out "\"~A\" [label=<<B>~A</B><BR /><I><FONT POINT-SIZE=\"10\">~{~A~^<BR ALIGN=\"LEFT\"/>~}</FONT></I>>]~%"
actual
actual
@ -1345,16 +1428,166 @@ color=lightblue;
do (format out "\"~A\" -> \"~A\" [weight=~A label=\"~A\"];~%" a b v v))
(princ "}" out))
(defun populate-track-links (train-list)
(defun populate-track-links (train-list &key match)
(reset-track-links-set)
(loop
for train in train-list
do (format t "~&*** Processing train ~A...~%" train)
do (time (with-simple-restart (next-file "Move on to the next file.")
(unarchive-trains-tar train #'populate-track-links-set))))
(unarchive-trains-tar train #'populate-track-links-set
:match match))))
(format t "~&*** Done; ~A links~%" (hash-table-size *track-links-set*)))
(defun write-track-links-graphviz-to-file (outfile)
(with-open-file (out outfile
:direction :output)
(write-track-links-graphviz :out out)))
(defclass train-history-entry ()
((universal-ts
:initarg :universal-ts
:reader universal-ts)))
(defclass train-identity-change (train-history-entry)
((wtt-id
:initarg :wtt-id
:reader wtt-id)
(wtt-trip
:initarg :wtt-trip
:reader wtt-trip)))
(defun universal-time-railway (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) "¾")
((>= s 30) "½")
((>= s 15) "¼")
(t "")))))
(defmethod print-object ((obj train-identity-change) stream)
(print-unreadable-object (obj stream :type t)
(with-slots (universal-ts wtt-id wtt-trip) obj
(format stream "at ~A: WTT ~A×~A"
(universal-time-railway universal-ts)
(or wtt-id "?")
(or wtt-trip "?")))))
(defclass train-destination-change (train-history-entry)
((destination
:initarg :destination
:reader destination)))
(defmethod print-object ((obj train-destination-change) stream)
(print-unreadable-object (obj stream :type t)
(with-slots (universal-ts destination) obj
(format stream "at ~A: destination ~A"
(universal-time-railway universal-ts)
destination))))
(defclass train-transit (train-history-entry)
((end-ts
:initarg :end-ts
:accessor end-ts)
(track-codes
:initarg :track-codes
:initform '()
:accessor track-codes)))
(defmethod print-object ((obj train-transit) stream)
(print-unreadable-object (obj stream :type t)
(with-slots (universal-ts end-ts track-codes) obj
(format stream "from ~A to ~A: ~A"
(universal-time-railway universal-ts)
(universal-time-railway end-ts)
(format-path track-codes)))))
(defclass train-station-stop (train-transit)
((station-name
:initarg :station-name
:reader station-name)
(platform
:initarg :platform
:reader platform)))
(defmethod print-object ((obj train-station-stop) stream)
(print-unreadable-object (obj stream :type t)
(with-slots (universal-ts end-ts track-codes station-name platform) obj
(format stream "from ~A to ~A: ~As at ~A (plat ~A), ~A"
(universal-time-railway universal-ts)
(universal-time-railway end-ts)
(- end-ts universal-ts)
station-name
platform
(format-path track-codes)))))
(defun extract-station-information (description)
(when (uiop:string-prefix-p "At " description)
(cl-ppcre:register-groups-bind (station-name platform)
("At (.+) Platform (.+)" description)
(return-from extract-station-information
(values station-name platform)))
(values (subseq description #.(length "At ")) nil)))
(defun make-train-history (train-id &key cached-descriptions)
"Return a list of train history entries for the given TRAIN-ID."
(let* ((current-identity nil)
(current-destination nil)
(current-entry nil)
(line-code (subseq train-id 0 1))
(track-descriptions (or cached-descriptions
(line-track-descriptions line-code)))
(ret nil))
(dolist (entry (sort (redis-cpk-sorted-set-all train-id) #'<
:key #'first))
(destructuring-bind (universal-ts observer train) entry
(declare (ignore observer))
(let* ((identity (list (nilify-zeros (set-no train))
(nilify-zeros (trip-no train))))
(descr (cdr (assoc (track-code train) track-descriptions
:test #'string=)))
(destination (or (destination-desc train)
"<somewhere>")))
(unless (equal destination current-destination)
(setf current-destination destination)
(push (make-instance 'train-destination-change
:destination destination
:universal-ts universal-ts)
ret))
(unless (equal identity current-identity)
(setf current-identity identity)
(push (make-instance 'train-identity-change
:wtt-id (first identity)
:wtt-trip (second identity)
:universal-ts universal-ts)
ret))
(multiple-value-bind (station-name platform)
(extract-station-information descr)
(unless (and current-entry
(eql (when station-name t)
(typep current-entry 'train-station-stop)))
(unless (eql current-entry nil)
(setf (end-ts current-entry) universal-ts)
(setf (track-codes current-entry)
(nreverse (track-codes current-entry)))
(push current-entry ret))
(setf current-entry
(if station-name
(make-instance 'train-station-stop
:station-name station-name
:platform platform
:universal-ts universal-ts
:end-ts universal-ts)
(make-instance 'train-transit
:universal-ts universal-ts
:end-ts universal-ts)))))
(pushnew (track-code train) (track-codes current-entry)
:test #'string=)
(setf (end-ts current-entry) universal-ts))))
(when current-entry
(push current-entry ret))
ret))

374
wobsite.lisp

@ -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 ()

396
wtt.lisp

@ -0,0 +1,396 @@
(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