Browse Source

WTT screwing around

master
eta 2 months ago
parent
commit
0aee118dfb
  1. 106
      wobsite.lisp
  2. 231
      wtt.lisp

106
wobsite.lisp

@ -359,6 +359,99 @@
: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)
@ -474,8 +567,11 @@
(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) (trackernet::redis-last-score train)))
(secs-old (- (get-universal-time) last-ts))
(train-data (trackernet::make-train-history
train
:cached-descriptions (cached-track-suggestions line-code)))
@ -537,6 +633,14 @@
(: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

231
wtt.lisp

@ -141,6 +141,44 @@
(: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*))
@ -163,3 +201,196 @@
(cpk:encode-to-file
(read-one-page "./wtt-district.pdf" page)
(format nil "./wtt-district-~A.cpk" page))))
(defvar *wtt-data* '())
(defun convert-abbreviation-to-offset (abbrev)
(ecase (elt abbrev 0)
(#\a 30)
(#\b 60)
(#\c 90)
(#\d 120)
(#\e 150)
(#\f 180)
(#\g 210)
(#\h 240)
(#\j 270)
(#\k 300)
(#\T 0)
(#\Space 0)))
(defclass wtt-train ()
((train-no
:initarg :train-no
:reader train-no)
(trip-no
:initarg :trip-no
:reader trip-no)
(notes
:initarg :notes
:reader notes)
(calling-points
:initarg :calling-points
:reader calling-points)
(to-form
:initarg :to-form
:reader to-form)
(from-page
:initarg :from-page
:reader from-page)
(runs-when
:initarg :runs-when
:reader runs-when)))
(defmethod print-object ((obj wtt-train) stream)
(print-unreadable-object (obj stream :type t)
(with-slots (train-no trip-no notes calling-points to-form from-page runs-when) obj
(format stream "~A×~A~@[ (notes: ~{~A~^, ~})~] runs ~A with ~A stops (first ~2,'0D~2,'0D at ~A), forms ~2,'0D~2,'0D (src p#~A)"
train-no trip-no notes runs-when (length calling-points)
(second (first calling-points)) (third (first calling-points))
(first (first calling-points))
(first to-form) (second to-form)
from-page))))
(defun parse-wtt-time (timestr)
(cl-ppcre:register-groups-bind (h abbrevs m halves)
("(\\d\\d)\\s*([abcdefghjkT ])?\\s*(\\d\\d)(.*)" timestr)
(let* ((h (parse-integer h))
(m (parse-integer m))
(offset (convert-abbreviation-to-offset (or abbrevs " ")))
(is-half (or
(and
(position #\1 halves)
(position #\2 halves))
(position #\1 halves))))
(list h m (if is-half 30 0) offset))))
(defvar *wtt-hash-table* (make-hash-table :test #'equal))
(defun strconcat (a b)
(concatenate 'string a b))
(defun parse-wtt-train-from-list (lst &key runs-when from-page)
(let ((train-no)
(trip-no)
(notes)
(to-form)
(calling-points))
(dolist (pair lst)
(let ((values (reduce #'strconcat (cdr pair))))
(case (car pair)
(:train-no
(setf train-no values))
(:trip-no
(setf trip-no (parse-integer values)))
(:to-form
(setf to-form (parse-wtt-time values)))
(:notes
(setf notes (delete-if
(lambda (x) (eql (length x) 0))
(cdr pair))))
(otherwise
(alexandria:when-let
((time (ignore-errors (parse-wtt-time values))))
(push (cons (car pair) time) calling-points))))))
(unless (and train-no trip-no calling-points)
(error "Train is missing data; ~Ax~A #cpts ~A"
train-no trip-no (length calling-points)))
(make-instance 'wtt-train
:train-no train-no
:trip-no trip-no
:notes notes
:to-form to-form
:runs-when runs-when
:from-page from-page
:calling-points (nreverse calling-points))))
(defun headers-to-runtime (header-left header-right)
(let ((total-string
(reduce #'strconcat
(reduce #'append (list header-left header-right)))))
(cond
((search "MONDAY" total-string)
:weekdays)
((search "SATURDAY" total-string)
:saturdays)
((search "SUNDAY" total-string)
:sundays)
(t
(error "Unknown headers ~A" total-string)))))
(defun add-wtt-page-to-table (page)
(destructuring-bind
(page-no header-left header-right &rest trains)
page
(format t "~&processing page #~A: ~A — ~A (~A trains)~%"
page-no header-left header-right (length trains))
(let ((runs-when (headers-to-runtime header-left header-right)))
(dolist (trn trains)
(handler-case
(let* ((wtt-train (parse-wtt-train-from-list
trn
:runs-when runs-when
:from-page page-no))
(train-no
(string-trim
'(#\D #\E #\W)
(train-no wtt-train))))
(setf (gethash train-no *wtt-hash-table*)
(cons wtt-train
(gethash train-no *wtt-hash-table*))))
(error (e)
(warn "Failed to parse train: ~A" e)))))))
(defun add-wtt-pages-to-table (pages-list)
(dolist (page pages-list)
(with-simple-restart (continue "Skip this page and continue.")
(add-wtt-page-to-table
(car
(cpk:decode-file page))))))
(defun import-wtt-pages (pages-list)
(clrhash *wtt-hash-table*)
(add-wtt-pages-to-table pages-list)
(loop
for train-no being the hash-keys of *wtt-hash-table*
do (setf (gethash train-no *wtt-hash-table*)
(sort
(gethash train-no *wtt-hash-table*)
#'<
:key #'trip-no)))
(hash-table-count *wtt-hash-table*))
(defun find-wtt-for (train-no trip-no runs-when)
(alexandria:when-let
((trains (gethash train-no *wtt-hash-table*)))
(find-if
(lambda (trn)
(and
(eql (trip-no trn) trip-no)
(eql (runs-when trn) runs-when)))
trains)))
(defun time-compare (timea timeb func)
(funcall func
(+ (* (first timea) 60)
(second timea))
(+ (* (first timeb) 60)
(second timeb))))
(defun find-wtt-for-time (train-no time runs-when)
(alexandria:when-let
((trains (gethash train-no *wtt-hash-table*)))
(find-if
(lambda (trn)
(and
(eql (runs-when trn) runs-when)
(time-compare
(cdr (first (calling-points trn)))
time
#'<=)
(time-compare
(cdr (car (last (calling-points trn))))
time
#'>=)))
trains)))
Loading…
Cancel
Save