WTT screwing around

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) 
 
 

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

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

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

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