Initial rewrite
parent
6e31a1c2eb
commit
cd73f82d47
|
@ -0,0 +1,3 @@
|
||||||
|
((css-mode (indent-tabs-mode . t)
|
||||||
|
(tab-width . 8)
|
||||||
|
(css-indent-offset . 8)))
|
|
@ -1,6 +1,6 @@
|
||||||
ywatds - a simple server program that provides data based on advtrains savefiles
|
ywatds - a simple server program that provides data based on advtrains savefiles
|
||||||
|
|
||||||
**Please note that this project is still WIP and experimental. Use at your own risk.**
|
**Please note that this project is still WIP and experimental. Use at your own risk. _Work is currently in progress to rewrite this set of programs in GNU Guile Scheme._**
|
||||||
|
|
||||||
## Usage
|
## Usage
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,5 @@
|
||||||
|
(define-module (aux math)
|
||||||
|
#:export (floor-exact))
|
||||||
|
|
||||||
|
(define (floor-exact n)
|
||||||
|
(floor (inexact->exact n)))
|
|
@ -0,0 +1,69 @@
|
||||||
|
(define-module (aux v2d)
|
||||||
|
#:export (v2d?
|
||||||
|
v2d+ v2d- v2d* v2d/
|
||||||
|
v2d-floor
|
||||||
|
v2d-length v2d-extend-to-length
|
||||||
|
v2d-midpoint v2d-slope v2d-intersection))
|
||||||
|
|
||||||
|
(define (v2d? obj)
|
||||||
|
(and (pair? obj)
|
||||||
|
(real? (car obj)) (finite? (car obj))
|
||||||
|
(real? (cdr obj)) (finite? (cdr obj))))
|
||||||
|
|
||||||
|
(import (rnrs base (6)))
|
||||||
|
|
||||||
|
(define (ensure-v2d obj)
|
||||||
|
(if (pair? obj) (begin (assert (v2d? obj)) obj)
|
||||||
|
(ensure-v2d (cons obj obj))))
|
||||||
|
|
||||||
|
(define (v2d-map proc lst)
|
||||||
|
(let ((v2ds (map-in-order ensure-v2d lst)))
|
||||||
|
(ensure-v2d
|
||||||
|
(cons (apply proc (map-in-order car v2ds))
|
||||||
|
(apply proc (map-in-order cdr v2ds))))))
|
||||||
|
|
||||||
|
(define (v2d-length obj)
|
||||||
|
(let ((v2d (ensure-v2d obj)))
|
||||||
|
(sqrt (+ (expt (car v2d) 2) (expt (cdr v2d) 2)))))
|
||||||
|
|
||||||
|
(define (v2d+ . lst) (v2d-map + lst))
|
||||||
|
(define (v2d- . lst) (v2d-map - lst))
|
||||||
|
(define (v2d* . lst) (v2d-map * lst))
|
||||||
|
(define (v2d/ . lst) (v2d-map / lst))
|
||||||
|
|
||||||
|
(define (v2d-floor obj)
|
||||||
|
(let ((v2d (ensure-v2d obj)))
|
||||||
|
(cons (floor (inexact->exact (car v2d)))
|
||||||
|
(floor (inexact->exact (cdr v2d))))))
|
||||||
|
|
||||||
|
(define (v2d-extend-to-length v2d length)
|
||||||
|
(let* ((cur-length (v2d-length v2d))
|
||||||
|
(factor (/ length cur-length)))
|
||||||
|
(v2d* v2d factor)))
|
||||||
|
|
||||||
|
(define (v2d-midpoint obj1 obj2)
|
||||||
|
(v2d/ (v2d+ obj1 obj2) 2))
|
||||||
|
|
||||||
|
(define (v2d-slope obj)
|
||||||
|
(let ((v2d (ensure-v2d obj)))
|
||||||
|
(if (zero? (car v2d)) (inf) (/ (cdr v2d) (car v2d)))))
|
||||||
|
|
||||||
|
(define (v2d-intersection v2d1 v2d2 dir1 dir2)
|
||||||
|
(let* ((p1 (ensure-v2d v2d1)) (p2 (ensure-v2d v2d2))
|
||||||
|
(d1 (ensure-v2d dir1)) (d2 (ensure-v2d dir2))
|
||||||
|
(u1? (zero? (car d1))) (u2? (zero? (car d2))))
|
||||||
|
(cond
|
||||||
|
(u1? (if u2?
|
||||||
|
(if (= (cdr p1) (cdr p2)) #f (v2d-midpoint p1 p2))
|
||||||
|
(let* ((a (v2d-slope d2))
|
||||||
|
(b (cdr (v2d- p2 (v2d* (cons 1 a) (car p2))))))
|
||||||
|
(cons (car p1) (+ (* a (car p1)) b)))))
|
||||||
|
(u2? (v2d-intersection p2 p1 d2 d1))
|
||||||
|
(#t (let* ((a1 (v2d-slope d1)) (a2 (v2d-slope d2))
|
||||||
|
(b1 (cdr (v2d- p1 (v2d* (cons 1 a1) (car p1)))))
|
||||||
|
(b2 (cdr (v2d- p2 (v2d* (cons 1 a2) (car p2))))))
|
||||||
|
(if (= a1 a2)
|
||||||
|
#f
|
||||||
|
(let* ((x (/ (- b2 b1) (- a1 a2)))
|
||||||
|
(y (+ b1 (* a1 x))))
|
||||||
|
(cons x y))))))))
|
|
@ -0,0 +1,114 @@
|
||||||
|
(include "paths.scm")
|
||||||
|
(use-modules (ice-9 regex)
|
||||||
|
(ice-9 textual-ports)
|
||||||
|
(ice-9 binary-ports)
|
||||||
|
(ice-9 threads)
|
||||||
|
(srfi srfi-19)
|
||||||
|
(sxml simple)
|
||||||
|
(web request) (web response) (web server) (web uri)
|
||||||
|
;; custom modules listed below
|
||||||
|
(tracks nodedb)
|
||||||
|
(webui html) (webui svg))
|
||||||
|
|
||||||
|
(define dataserver-handlers '())
|
||||||
|
|
||||||
|
;; taken from https://www.gnu.org/software/guile/manual/html_node/Web-Examples.html
|
||||||
|
(define (request-path-components request)
|
||||||
|
(split-and-decode-uri-path (uri-path (request-uri request))))
|
||||||
|
|
||||||
|
(define (request-query request)
|
||||||
|
(let* ((qstring (or (uri-query (request-uri request)) ""))
|
||||||
|
(qstring-matches (list-matches "[^&]+" qstring))
|
||||||
|
(parse-element
|
||||||
|
(lambda (match)
|
||||||
|
(let* ((str (match:substring match))
|
||||||
|
(eq-pos (string-index str #\=)))
|
||||||
|
(if eq-pos
|
||||||
|
(cons (uri-decode (string-take str eq-pos))
|
||||||
|
(uri-decode (string-drop str (+ 1 eq-pos))))
|
||||||
|
(uri-decode str))))))
|
||||||
|
(map-in-order parse-element qstring-matches)))
|
||||||
|
|
||||||
|
(define* (respond body #:key
|
||||||
|
(status 200)
|
||||||
|
(content-type 'text/plain)
|
||||||
|
(extra-headers '()))
|
||||||
|
(let* ((content-type-data `(,content-type (charset . "utf-8"))))
|
||||||
|
(values
|
||||||
|
(build-response #:code status
|
||||||
|
#:headers `((content-type . ,content-type-data)
|
||||||
|
,@extra-headers))
|
||||||
|
body)))
|
||||||
|
|
||||||
|
(define* (respond-html body #:key
|
||||||
|
(status 200)
|
||||||
|
(extra-headers '()))
|
||||||
|
(let* ((page (apply build-html-page body)))
|
||||||
|
(respond (lambda (port)
|
||||||
|
(put-string port "<!DOCTYPE html>")
|
||||||
|
(sxml->xml page port))
|
||||||
|
#:status status
|
||||||
|
#:content-type 'text/html
|
||||||
|
#:extra-headers extra-headers)))
|
||||||
|
|
||||||
|
(define* (respond-svg body #:key
|
||||||
|
(status 200)
|
||||||
|
(extra-headers '()))
|
||||||
|
(let ((page (apply svg body)))
|
||||||
|
(respond (lambda (port) (sxml->xml page port))
|
||||||
|
#:status status
|
||||||
|
#:content-type 'image/svg+xml
|
||||||
|
#:extra-headers extra-headers)))
|
||||||
|
|
||||||
|
(define (handle-not-found request body)
|
||||||
|
(respond-html `("Not found" "The requested path "
|
||||||
|
(code ,(uri->string (request-uri request)))
|
||||||
|
" could not be found on this server.")
|
||||||
|
#:status 404))
|
||||||
|
|
||||||
|
(define (dataserver-handler request body)
|
||||||
|
(letrec* ((path (request-path-components request))
|
||||||
|
(query (request-query request))
|
||||||
|
(f (lambda (handlers)
|
||||||
|
(cond
|
||||||
|
((null? handlers) (handle-not-found request body))
|
||||||
|
((equal? (caar handlers) path)
|
||||||
|
((cdar handlers) query))
|
||||||
|
(#t (f (cdr handlers)))))))
|
||||||
|
(format #t "[~a] ~a ~s -> ~s~%"
|
||||||
|
(date->string (current-date) "~5")
|
||||||
|
(request-method request)
|
||||||
|
(uri->string (request-uri request))
|
||||||
|
path)
|
||||||
|
(f dataserver-handlers)))
|
||||||
|
|
||||||
|
(define (default-stylesheet-handler _)
|
||||||
|
(respond
|
||||||
|
(call-with-input-file "webui/style.css" get-string-all #:binary #t)
|
||||||
|
#:content-type 'text/css))
|
||||||
|
|
||||||
|
(define (default-icon-handler _)
|
||||||
|
(respond
|
||||||
|
(call-with-input-file "webui/favicon.ico" get-bytevector-all
|
||||||
|
#:binary #t)
|
||||||
|
#:content-type 'image/vnd.microsoft.icon))
|
||||||
|
|
||||||
|
(set! dataserver-handlers
|
||||||
|
(cons* `(("style.css") . ,default-stylesheet-handler)
|
||||||
|
`(("favicon.ico") . ,default-icon-handler)
|
||||||
|
dataserver-handlers))
|
||||||
|
|
||||||
|
;; Handlers
|
||||||
|
(include "webui/conns.scm")
|
||||||
|
(include "webui/registered-tracks.scm")
|
||||||
|
(include "webui/nodedb.scm")
|
||||||
|
(include "webui/perfdata.scm")
|
||||||
|
|
||||||
|
(define nodedb-path (string-append world-path "/advtrains_ndb4.ls"))
|
||||||
|
(define nodedb-dump-path (string-append script-path "/nodedb.svg"))
|
||||||
|
|
||||||
|
(define (load-data)
|
||||||
|
(load-nodedb nodedb-path))
|
||||||
|
|
||||||
|
(load-data)
|
||||||
|
(call-with-new-thread (lambda () (run-server dataserver-handler)))
|
|
@ -0,0 +1,7 @@
|
||||||
|
(define script-path (dirname (current-filename)))
|
||||||
|
(define world-path (cadr (program-arguments)))
|
||||||
|
|
||||||
|
(let ((addf (lambda (x)
|
||||||
|
(add-to-load-path (string-append script-path "/" x)))))
|
||||||
|
(add-to-load-path script-path)
|
||||||
|
(for-each addf '("aux" "tracks" "webui")))
|
|
@ -0,0 +1,92 @@
|
||||||
|
(define-module (tracks conns)
|
||||||
|
#:export (track-conns
|
||||||
|
conns-turnout conns-turnout-flat
|
||||||
|
conns-crossings conns-crossings-flat
|
||||||
|
track-dir-adjust track-conns-adjust track-clist-adjust
|
||||||
|
clist-optimize))
|
||||||
|
|
||||||
|
(use-modules (srfi srfi-1) (srfi srfi-69))
|
||||||
|
|
||||||
|
(define dir-objects (make-vector 32))
|
||||||
|
(do ((i 0 (1+ i))) ((> i 31))
|
||||||
|
(vector-set! dir-objects i `(,(ash i -1) . ,(bit-extract i 0 1))))
|
||||||
|
(define conns-objects (make-vector 1024))
|
||||||
|
(do ((i 0 (1+ i))) ((> i 1023))
|
||||||
|
(vector-set!
|
||||||
|
conns-objects i
|
||||||
|
`(,(vector-ref dir-objects (ash i -5)) .
|
||||||
|
,(vector-ref dir-objects (bit-extract i 0 5)))))
|
||||||
|
|
||||||
|
(define* (track-conns c1 c2 #:optional (r1 0) (r2 0))
|
||||||
|
(vector-ref conns-objects (+ (ash c1 6) (ash r1 5) (ash c2 1) r2)))
|
||||||
|
|
||||||
|
(define* (conns-turnout clist #:optional (rlist '()))
|
||||||
|
(let ((c1 (car clist)) (cr (cdr clist)))
|
||||||
|
(if (null? rlist)
|
||||||
|
(map-in-order (lambda (x) (track-conns c1 x)) cr)
|
||||||
|
(let ((r1 (car rlist)) (rr (cdr rlist)))
|
||||||
|
(map-in-order (lambda (c r) (track-conns c1 c r1 r)) cr rr)))))
|
||||||
|
|
||||||
|
(define (conns-turnout-flat . clist)
|
||||||
|
(conns-turnout clist))
|
||||||
|
|
||||||
|
(define* (conns-crossings clist #:optional (rlist '()))
|
||||||
|
(letrec ((f (lambda (lst cl rl)
|
||||||
|
(cond
|
||||||
|
((null? cl) lst)
|
||||||
|
((null? rl)
|
||||||
|
(f (cons (track-conns (car cl) (cadr cl)) lst)
|
||||||
|
(cddr cl) '()))
|
||||||
|
(#t (f (cons (track-conns (car cl) (cadr cl)
|
||||||
|
(car rl) (cadr rl))
|
||||||
|
lst) (cddr cl) (cddr rl)) '())))))
|
||||||
|
(reverse (f '() clist rlist))))
|
||||||
|
|
||||||
|
(define (conns-crossings-flat . clist)
|
||||||
|
(conns-crossings clist))
|
||||||
|
|
||||||
|
(define (track-dir-adjust-aux n offset)
|
||||||
|
(modulo (+ n offset) 16))
|
||||||
|
|
||||||
|
(define (track-dir-adjust dir offset)
|
||||||
|
(let ((c (track-dir-adjust-aux (car dir) offset))
|
||||||
|
(r (cdr dir)))
|
||||||
|
(vector-ref dir-objects (+ (* 2 c) r))))
|
||||||
|
|
||||||
|
(define (track-conns-adjust conns offset)
|
||||||
|
(let ((c1 (track-dir-adjust-aux (caar conns) offset))
|
||||||
|
(c2 (track-dir-adjust-aux (cadr conns) offset)))
|
||||||
|
(track-conns c1 c2 (cdar conns) (cddr conns))))
|
||||||
|
|
||||||
|
(define (track-clist-adjust clist offset)
|
||||||
|
(let ((f (lambda (x) (track-conns-adjust x offset))))
|
||||||
|
(map-in-order f clist)))
|
||||||
|
|
||||||
|
(define (conns->small-int conns)
|
||||||
|
(let* ((aux (lambda (from to)
|
||||||
|
(+ (ash (car from) 6) (ash (cdr from) 5)
|
||||||
|
(ash (car to) 1) (cdr to))))
|
||||||
|
(from (car conns)) (to (cdr conns)))
|
||||||
|
(if (> (car from) (car to)) (aux to from) (aux from to))))
|
||||||
|
|
||||||
|
(define clist-shared-objects (make-hash-table))
|
||||||
|
(define (clist-optimize clist)
|
||||||
|
(letrec* ((nlist (delete-duplicates!
|
||||||
|
(sort-list! (map conns->small-int clist) <)
|
||||||
|
=))
|
||||||
|
(get-shared-obj
|
||||||
|
(lambda (obj)
|
||||||
|
(if (null? obj) '()
|
||||||
|
(if (hash-table-exists? clist-shared-objects obj)
|
||||||
|
(hash-table-ref clist-shared-objects obj)
|
||||||
|
(let ((newobj
|
||||||
|
(cons (vector-ref conns-objects (car obj))
|
||||||
|
(cdr obj))))
|
||||||
|
(hash-table-set! clist-shared-objects obj newobj)
|
||||||
|
newobj)))))
|
||||||
|
(share-obj
|
||||||
|
(lambda (lst)
|
||||||
|
(if (null? lst) '()
|
||||||
|
(get-shared-obj
|
||||||
|
(cons (car lst) (share-obj (cdr lst))))))))
|
||||||
|
(share-obj nlist)))
|
|
@ -0,0 +1,63 @@
|
||||||
|
(define-module (tracks nodedb)
|
||||||
|
#:export (nodedb
|
||||||
|
load-nodedb))
|
||||||
|
|
||||||
|
(use-modules (ice-9 binary-ports) (ice-9 textual-ports)
|
||||||
|
(rnrs bytevectors)
|
||||||
|
(srfi srfi-2) (srfi srfi-69)
|
||||||
|
(tracks register))
|
||||||
|
|
||||||
|
(define nodedb (make-hash-table))
|
||||||
|
|
||||||
|
(define (load-nodedb filename)
|
||||||
|
(letrec* ((names (make-vector 65536 #f))
|
||||||
|
(nodes (make-hash-table))
|
||||||
|
(read-bv
|
||||||
|
(lambda (port n)
|
||||||
|
(and-let* ((v (get-bytevector-n port n))
|
||||||
|
((not (eof-object? v)))
|
||||||
|
((= (bytevector-length v) n)))
|
||||||
|
v)))
|
||||||
|
(bo (endianness big))
|
||||||
|
(read-u16
|
||||||
|
(lambda (port)
|
||||||
|
(and-let* ((v (read-bv port 2)))
|
||||||
|
(bytevector-u16-ref v 0 bo))))
|
||||||
|
(balance (lambda (n) (- n 32768)))
|
||||||
|
(read-int
|
||||||
|
(lambda (port)
|
||||||
|
(and-let* ((n (read-u16 port)))
|
||||||
|
(balance n))))
|
||||||
|
(read-node-entry
|
||||||
|
(lambda (port)
|
||||||
|
(and-let* ((v (read-bv port 8))
|
||||||
|
(b (lambda (v i)
|
||||||
|
(balance (bytevector-u16-ref v i bo))))
|
||||||
|
(x (b v 0)) (y (b v 2)) (z (b v 4)) (id (b v 6))
|
||||||
|
(c (list x y z))
|
||||||
|
(n (+ (ash id -2) 32768))
|
||||||
|
(p (bit-extract id 0 2)))
|
||||||
|
(and-let* ((s (vector-ref names n)))
|
||||||
|
(hash-table-set! nodes c (vector-ref s p)))
|
||||||
|
#t)))
|
||||||
|
(read-node-definition
|
||||||
|
(lambda (port)
|
||||||
|
(let* ((k (read-u16 port)) (v (get-line port)))
|
||||||
|
(when (and v (hash-table-exists? registered-tracks v))
|
||||||
|
(vector-set! names k
|
||||||
|
(hash-table-ref registered-tracks v))))))
|
||||||
|
(read-node-definitions
|
||||||
|
(lambda (port)
|
||||||
|
(do ((i (read-int port) (- i 1))) ((zero? i))
|
||||||
|
(read-node-definition port))))
|
||||||
|
(read-nodes (lambda (port) (while (read-node-entry port))))
|
||||||
|
(read-ndb
|
||||||
|
(lambda (port)
|
||||||
|
(unless (equal? (get-u8 port) 1)
|
||||||
|
(error "wrong nodedb version"))
|
||||||
|
(read-node-definitions port)
|
||||||
|
(read-nodes port)
|
||||||
|
(set! nodedb nodes))))
|
||||||
|
(call-with-input-file filename read-ndb #:binary #t)
|
||||||
|
(format #t "Node database: ~d tracks in database~%"
|
||||||
|
(hash-table-size nodedb))))
|
|
@ -0,0 +1,109 @@
|
||||||
|
(define-module (tracks register)
|
||||||
|
#:export (registered-tracks))
|
||||||
|
(use-modules (srfi srfi-43) (srfi srfi-69) (tracks conns))
|
||||||
|
|
||||||
|
(define registered-tracks (make-hash-table string=? string-hash))
|
||||||
|
|
||||||
|
(define (register-track name clist)
|
||||||
|
(let* ((f (lambda (_ x) (clist-optimize (track-clist-adjust clist x))))
|
||||||
|
(d (vector 0 4 8 12)))
|
||||||
|
(vector-map! f d)
|
||||||
|
(hash-table-set! registered-tracks name d)))
|
||||||
|
|
||||||
|
(define (register-tracks names clist)
|
||||||
|
(let ((f (lambda (x) (register-track x clist))))
|
||||||
|
(if (list? names) (map f names) (f names))))
|
||||||
|
|
||||||
|
(define (register-rotatable-track name clist)
|
||||||
|
(let ((f (lambda (suffix offset)
|
||||||
|
(register-track (string-append name suffix)
|
||||||
|
(track-clist-adjust clist offset)))))
|
||||||
|
(map f '("" "_30" "_45" "_60") '(0 1 2 3))))
|
||||||
|
|
||||||
|
(define (register-rotatable-tracks names clist)
|
||||||
|
(let ((f (lambda (x) (register-rotatable-track x clist))))
|
||||||
|
(if (list? names) (map f names) (f names))))
|
||||||
|
|
||||||
|
(define (prefix-names prefix names)
|
||||||
|
(let ((f (lambda (x) (string-append prefix "_" x))))
|
||||||
|
(if (list? names) (map-in-order f names) (f names))))
|
||||||
|
|
||||||
|
(define (register-tracks-with-preset . defs)
|
||||||
|
(lambda (prefix)
|
||||||
|
(letrec ((f (lambda (lst)
|
||||||
|
(unless (null? lst)
|
||||||
|
(register-tracks (prefix-names prefix (car lst))
|
||||||
|
(cadr lst))
|
||||||
|
(f (cddr lst))))))
|
||||||
|
(f defs))))
|
||||||
|
|
||||||
|
(define (register-rotatable-tracks-with-preset . defs)
|
||||||
|
(lambda (prefix)
|
||||||
|
(letrec ((f (lambda (lst)
|
||||||
|
(unless (null? lst)
|
||||||
|
(register-rotatable-tracks
|
||||||
|
(prefix-names prefix (car lst))
|
||||||
|
(cadr lst))
|
||||||
|
(f (cddr lst))))))
|
||||||
|
(f defs))))
|
||||||
|
|
||||||
|
(define register-default-tracks
|
||||||
|
(register-rotatable-tracks-with-preset
|
||||||
|
"st" (conns-turnout-flat 0 8)
|
||||||
|
"cr" (conns-turnout-flat 0 7)
|
||||||
|
'("swlst" "swlcr") (conns-turnout-flat 0 8 7)
|
||||||
|
'("swrst" "swrcr") (conns-turnout-flat 0 8 9)))
|
||||||
|
|
||||||
|
(define register-y-turnout-tracks
|
||||||
|
(register-rotatable-tracks-with-preset
|
||||||
|
'("l" "r") (conns-turnout-flat 0 7 9)))
|
||||||
|
|
||||||
|
(define register-3way-turnout-tracks
|
||||||
|
(register-rotatable-tracks-with-preset
|
||||||
|
'("l" "s" "r") (conns-turnout-flat 0 7 8 9)))
|
||||||
|
|
||||||
|
(define register-slope-tracks
|
||||||
|
(register-rotatable-tracks-with-preset
|
||||||
|
'("vst1" "vst31" "vst32") (conns-turnout-flat 8 0)
|
||||||
|
'("vst2" "vst33") (conns-turnout '(8 0) '(0 1))))
|
||||||
|
|
||||||
|
(define register-straightonly-tracks
|
||||||
|
(register-rotatable-tracks-with-preset
|
||||||
|
"st" (conns-turnout-flat 0 8)))
|
||||||
|
|
||||||
|
(define register-perp-xing-tracks
|
||||||
|
(register-rotatable-tracks-with-preset
|
||||||
|
"st" (conns-crossings-flat 0 8 4 12)))
|
||||||
|
|
||||||
|
(define register-90+x-xing-tracks
|
||||||
|
(register-rotatable-tracks-with-preset
|
||||||
|
"30l" (conns-crossings-flat 0 8 1 9)
|
||||||
|
"45l" (conns-crossings-flat 0 8 2 10)
|
||||||
|
"60l" (conns-crossings-flat 0 8 3 11)
|
||||||
|
"60r" (conns-crossings-flat 0 8 5 13)
|
||||||
|
"45r" (conns-crossings-flat 0 8 6 14)
|
||||||
|
"30r" (conns-crossings-flat 0 8 7 15)))
|
||||||
|
|
||||||
|
(define register-diag-xing-tracks
|
||||||
|
(register-tracks-with-preset
|
||||||
|
"30l45r" (conns-crossings-flat 1 9 6 14)
|
||||||
|
"60l30l" (conns-crossings-flat 3 11 1 9)
|
||||||
|
"60l45r" (conns-crossings-flat 3 11 6 14)
|
||||||
|
"60l60r" (conns-crossings-flat 3 11 5 13)
|
||||||
|
"60r45l" (conns-crossings-flat 5 13 2 10)
|
||||||
|
"60r30r" (conns-crossings-flat 5 13 7 15)
|
||||||
|
"30r45l" (conns-crossings-flat 7 15 2 10)))
|
||||||
|
|
||||||
|
(register-default-tracks "advtrains:dtrack")
|
||||||
|
(register-y-turnout-tracks "advtrains:dtrack_sy")
|
||||||
|
(register-3way-turnout-tracks "advtrains:dtrack_s3")
|
||||||
|
(register-perp-xing-tracks "advtrains:dtrack_xing")
|
||||||
|
(register-90+x-xing-tracks "advtrains:dtrack_xing90plusx")
|
||||||
|
(register-diag-xing-tracks "advtrains:dtrack_xingdiag")
|
||||||
|
(register-slope-tracks "advtrains:dtrack")
|
||||||
|
(register-straightonly-tracks "advtrains:dtrack_bumper")
|
||||||
|
(register-straightonly-tracks "advtrains:dtrack_atc")
|
||||||
|
(register-straightonly-tracks "advtrains:dtrack_unload")
|
||||||
|
(register-straightonly-tracks "advtrains:dtrack_load")
|
||||||
|
(register-straightonly-tracks "advtrains:dtrack_detector_off")
|
||||||
|
(register-straightonly-tracks "advtrains:dtrack_detector_on")
|
|
@ -0,0 +1,173 @@
|
||||||
|
(use-modules (aux v2d) (aux math))
|
||||||
|
|
||||||
|
(define (conns-query->qstring qlist)
|
||||||
|
(let ((f (lambda (elem) (format #f "~d=~d" (car elem) (cdr elem)))))
|
||||||
|
(format #f "~{~a~^&~}" (map-in-order f qlist))))
|
||||||
|
|
||||||
|
(define (conns-handler-get-query qlist)
|
||||||
|
(let* ((valid-conns-string?
|
||||||
|
(lambda (str)
|
||||||
|
(and (string-every char-numeric? str)
|
||||||
|
(let ((snum (string->number str)))
|
||||||
|
(and (integer? snum) (< snum 16) (>= snum 0))))))
|
||||||
|
(query-filter
|
||||||
|
(lambda (elem)
|
||||||
|
(and (pair? elem)
|
||||||
|
(valid-conns-string? (car elem))
|
||||||
|
(valid-conns-string? (cdr elem)))))
|
||||||
|
(seen? (make-vector 256 #f))
|
||||||
|
(query-iter
|
||||||
|
(lambda (elem)
|
||||||
|
(and (query-filter elem)
|
||||||
|
(let* ((from (string->number (car elem)))
|
||||||
|
(to (string->number (cdr elem)))
|
||||||
|
(idx (+ (* 16 from) to)))
|
||||||
|
(and (not (vector-ref seen? idx))
|
||||||
|
(begin
|
||||||
|
(vector-set! seen? idx #t)
|
||||||
|
(cons from to))))))))
|
||||||
|
(delq! #f (map query-iter qlist))))
|
||||||
|
|
||||||
|
(define half-curve-memoization (make-vector 256 #f))
|
||||||
|
|
||||||
|
(define (clist->svg query)
|
||||||
|
(let* ((svg-size 512)
|
||||||
|
(adjust (lambda (x n) (modulo (+ x n) 16)))
|
||||||
|
(dir->pos-map
|
||||||
|
;; note that this vector maps north to -y
|
||||||
|
#((0 . -1) (1/2 . -1) (1 . -1) (1 . -1/2)
|
||||||
|
(1 . 0) (1 . 1/2) (1 . 1) (1/2 . 1)
|
||||||
|
(0 . 1) (-1/2 . 1) (-1 . 1) (-1 . 1/2)
|
||||||
|
(-1 . 0) (-1 . -1/2) (-1 . -1) (-1/2 . -1)))
|
||||||
|
(dir->pos (lambda (dir size)
|
||||||
|
(let ((pos-entry (vector-ref dir->pos-map dir)))
|
||||||
|
(v2d* (v2d+ pos-entry 1) size 1/2))))
|
||||||
|
(offset-pos (lambda (pos dir length)
|
||||||
|
(let ((ent (vector-ref dir->pos-map dir)))
|
||||||
|
(v2d+ (v2d-extend-to-length ent length) pos))))
|
||||||
|
(half-curve
|
||||||
|
(lambda (from to size width)
|
||||||
|
(let* ((idx (+ (* 16 from) to))
|
||||||
|
(memoization (vector-ref half-curve-memoization idx)))
|
||||||
|
(if memoization memoization
|
||||||
|
(let*
|
||||||
|
((aux (lambda (dir off)
|
||||||
|
(v2d-floor (offset-pos (dir->pos dir size)
|
||||||
|
(adjust dir off)
|
||||||
|
(/ width 2)))))
|
||||||
|
(p1 (aux from 4))
|
||||||
|
(p2 (aux to 12))
|
||||||
|
(p0 (v2d-floor (v2d+ (v2d*
|
||||||
|
(vector-ref dir->pos-map from)
|
||||||
|
width)
|
||||||
|
p1)))
|
||||||
|
(p3 (v2d-floor (v2d+ (v2d*
|
||||||
|
(vector-ref dir->pos-map to)
|
||||||
|
width)
|
||||||
|
p2)))
|
||||||
|
(d1 (v2d- (vector-ref dir->pos-map from)))
|
||||||
|
(d2 (v2d- (vector-ref dir->pos-map to)))
|
||||||
|
(c (v2d-intersection p1 p2 d1 d2))
|
||||||
|
(s (if c
|
||||||
|
(format
|
||||||
|
#f "~d~@dL~d~@dQ~d~@d~@d~@dL~d~@d"
|
||||||
|
(car p0) (cdr p0) (car p1) (cdr p1)
|
||||||
|
(floor-exact (car c))
|
||||||
|
(floor-exact (cdr c))
|
||||||
|
(car p2) (cdr p2) (car p3) (cdr p3))
|
||||||
|
(format
|
||||||
|
#f "~d~@dL~d~@dL~d~@dL~d~@d"
|
||||||
|
(car p0) (cdr p0) (car p1) (cdr p1)
|
||||||
|
(car p2) (cdr p2) (car p3) (cdr p3)))))
|
||||||
|
(vector-set! half-curve-memoization idx s)
|
||||||
|
s)))))
|
||||||
|
(make-path-entry
|
||||||
|
(lambda (elem)
|
||||||
|
(let* ((size svg-size)
|
||||||
|
(width (/ size 4))
|
||||||
|
(from (car elem))
|
||||||
|
(to (cdr elem))
|
||||||
|
(c1 (half-curve from to size width))
|
||||||
|
(c2 (half-curve to from size width)))
|
||||||
|
(if (and c1 c2)
|
||||||
|
(format #f "M~aL~aZ" c1 c2)
|
||||||
|
""))))
|
||||||
|
(path-string (string-concatenate (map make-path-entry query))))
|
||||||
|
`(,svg-size
|
||||||
|
,svg-size
|
||||||
|
(path (@ (d ,path-string)
|
||||||
|
(stroke "#000")
|
||||||
|
(stroke-width ,(floor-exact (/ svg-size 32)))
|
||||||
|
(fill "#be2d2c"))))))
|
||||||
|
|
||||||
|
(define (conns-handler-draw-svg original-query)
|
||||||
|
(let ((query (conns-handler-get-query original-query)))
|
||||||
|
(respond-svg (clist->svg query))))
|
||||||
|
|
||||||
|
(define (conns-handler-draw-preview-page original-query)
|
||||||
|
(let* ((dirnames
|
||||||
|
#("N" "NNE" "NE" "ENE" "E" "ESE" "SE" "SSE"
|
||||||
|
"S" "SSW" "SW" "WSW" "W" "WNW" "NW" "NNW"))
|
||||||
|
(query (conns-handler-get-query original-query))
|
||||||
|
(li-aux
|
||||||
|
(lambda (setter pair value)
|
||||||
|
(let ((cw (modulo (+ value 1) 16))
|
||||||
|
(ccw (modulo (+ value 15) 16)))
|
||||||
|
`((td (a (@ (href "/conns-preview?"
|
||||||
|
,(begin (setter pair ccw)
|
||||||
|
(conns-query->qstring query))))
|
||||||
|
"\u21b6"))
|
||||||
|
(td ,(format #f "~a" (vector-ref dirnames value)))
|
||||||
|
(td (a (@ (href "/conns-preview?"
|
||||||
|
,(begin (setter pair cw)
|
||||||
|
(conns-query->qstring query))))
|
||||||
|
"\u21b7"))
|
||||||
|
,(begin (setter pair value) "")))))
|
||||||
|
(colsep `(td (@ (style "margin:0;padding:0"))))
|
||||||
|
(rowsep `(tr (td (@ (style "margin:0;padding:0")
|
||||||
|
(colspan 9)))))
|
||||||
|
(li (lambda (elem)
|
||||||
|
`(tr
|
||||||
|
(td (a (@ (href "/conns-preview?"
|
||||||
|
,(conns-query->qstring
|
||||||
|
(delete elem query))))
|
||||||
|
"Delete"))
|
||||||
|
,colsep
|
||||||
|
,@(li-aux set-car! elem (car elem))
|
||||||
|
,colsep
|
||||||
|
,@(li-aux set-cdr! elem (cdr elem))))))
|
||||||
|
(respond-html
|
||||||
|
`("Conns preview"
|
||||||
|
(table (@ (class "standard-table align-center thick-table-borders")
|
||||||
|
(style "width:min-content"))
|
||||||
|
(tr (th "Action")
|
||||||
|
,colsep
|
||||||
|
(th (@ (colspan 3)) "From")
|
||||||
|
,colsep
|
||||||
|
(th (@ (colspan 3)) "To"))
|
||||||
|
,@(map-in-order li query)
|
||||||
|
(tr (td (a (@ (href "/conns-preview?"
|
||||||
|
,(conns-query->qstring
|
||||||
|
(append query '((0 . 8))))))
|
||||||
|
"(Add)"))
|
||||||
|
,colsep
|
||||||
|
(td (@ (class "unavailable") (colspan 3)) "N")
|
||||||
|
,colsep
|
||||||
|
(td (@ (class "unavailable") (colspan 3)) "S"))
|
||||||
|
,rowsep
|
||||||
|
(tr (th (@ (colspan 9)) "Preview"))
|
||||||
|
(tr (td (@ (colspan 9)
|
||||||
|
(style "margin:0;padding:0"))
|
||||||
|
(img (@ (src "/conns.svg?"
|
||||||
|
,(conns-query->qstring query))
|
||||||
|
(style "width:100%;height:auto;")))))
|
||||||
|
,rowsep
|
||||||
|
(tr (th (@ (colspan 9)) "Notes"))
|
||||||
|
(tr (td (@ (colspan 9)
|
||||||
|
(style "text-align:initial"))
|
||||||
|
"Duplicate entries are only shown once.")))))))
|
||||||
|
|
||||||
|
(set! dataserver-handlers
|
||||||
|
(cons* (cons '("conns.svg") conns-handler-draw-svg)
|
||||||
|
(cons '("conns-preview") conns-handler-draw-preview-page)
|
||||||
|
dataserver-handlers))
|
Binary file not shown.
After Width: | Height: | Size: 70 B |
|
@ -0,0 +1,26 @@
|
||||||
|
(define-module (webui html)
|
||||||
|
#:export (build-html-page
|
||||||
|
html-h1 html-h2 html-h3 html-h4 html-h5 html-h6))
|
||||||
|
(use-modules (sxml simple))
|
||||||
|
|
||||||
|
(define (html header . body)
|
||||||
|
(let ((title (if (string? header) header (car header)))
|
||||||
|
(bodydata (if (pair? header) (cdr header) '())))
|
||||||
|
`(html (head (title ,title)
|
||||||
|
(link (@ (rel "stylesheet") (href "/style.css")))
|
||||||
|
,@bodydata)
|
||||||
|
(body ,@body))))
|
||||||
|
|
||||||
|
(define (make-simple-tag-wrapper tagname)
|
||||||
|
(lambda body
|
||||||
|
`(,tagname ,@body)))
|
||||||
|
|
||||||
|
(define html-h1 (make-simple-tag-wrapper 'h1))
|
||||||
|
(define html-h2 (make-simple-tag-wrapper 'h2))
|
||||||
|
(define html-h3 (make-simple-tag-wrapper 'h3))
|
||||||
|
(define html-h4 (make-simple-tag-wrapper 'h4))
|
||||||
|
(define html-h5 (make-simple-tag-wrapper 'h5))
|
||||||
|
(define html-h6 (make-simple-tag-wrapper 'h6))
|
||||||
|
|
||||||
|
(define (build-html-page title . body)
|
||||||
|
(html title body))
|
|
@ -0,0 +1,16 @@
|
||||||
|
(define (perfdata-handler _)
|
||||||
|
(let* ((stats (gc-stats))
|
||||||
|
(dump-alist-aux (lambda (entry)
|
||||||
|
`(tr (td ,(format #f "~a" (car entry)))
|
||||||
|
(td ,(format #f "~a" (cdr entry))))))
|
||||||
|
(dump-alist (lambda (lst)
|
||||||
|
(map dump-alist-aux lst))))
|
||||||
|
(respond-html
|
||||||
|
`("Performance information"
|
||||||
|
(table (@ (class "standard-table"))
|
||||||
|
(tr (th (@ (colspan 2)) "GC Stats"))
|
||||||
|
,(dump-alist stats))))))
|
||||||
|
|
||||||
|
(set! dataserver-handlers
|
||||||
|
(cons* `(("perfdata") . ,perfdata-handler)
|
||||||
|
dataserver-handlers))
|
|
@ -0,0 +1,33 @@
|
||||||
|
(use-modules (srfi srfi-69) (tracks conns) (tracks register))
|
||||||
|
|
||||||
|
(define (conns-handler-registered-tracks qlist)
|
||||||
|
(let* ((sortf (lambda (ent1 ent2)
|
||||||
|
(string< (car ent1) (car ent2))))
|
||||||
|
(tracks (sort-list! (hash-table->alist registered-tracks) sortf))
|
||||||
|
(clist-mapf (lambda (ent) (cons (caar ent) (cadr ent))))
|
||||||
|
(conns-cell
|
||||||
|
(lambda (clist)
|
||||||
|
`(td (img (@ (src "/conns.svg?"
|
||||||
|
,@(conns-query->qstring
|
||||||
|
(map clist-mapf clist))))))))
|
||||||
|
(make-track-entry
|
||||||
|
(lambda (ent)
|
||||||
|
(let* ((cvects (cdr ent))
|
||||||
|
(clists (vector->list cvects))
|
||||||
|
(cells (map-in-order conns-cell clists)))
|
||||||
|
`(tr (td ,(car ent))
|
||||||
|
,@cells))))
|
||||||
|
(track-entries (map-in-order make-track-entry tracks))
|
||||||
|
(style (string-append
|
||||||
|
"img{height:calc(1em + 20px);width:auto;display:block}"
|
||||||
|
"td:not(:first-child){padding:0 !important}")))
|
||||||
|
(respond-html
|
||||||
|
`(("Known tracks" (style ,style))
|
||||||
|
(table (@ (class "standard-table"))
|
||||||
|
(tr (th "Name")
|
||||||
|
(th (@ (colspan 4)) "Conns"))
|
||||||
|
,@track-entries)))))
|
||||||
|
|
||||||
|
(set! dataserver-handlers
|
||||||
|
(cons* (cons '("registered-tracks") conns-handler-registered-tracks)
|
||||||
|
dataserver-handlers))
|
|
@ -0,0 +1,18 @@
|
||||||
|
table.standard-table {
|
||||||
|
border: solid 1px black;
|
||||||
|
border-collapse: collapse;
|
||||||
|
}
|
||||||
|
table.standard-table th, table.standard-table td{
|
||||||
|
border: solid 1px black;
|
||||||
|
padding: 5px;
|
||||||
|
}
|
||||||
|
table.thick-table-borders.standard-table {
|
||||||
|
border:solid 2px black;
|
||||||
|
}
|
||||||
|
.align-center, .align-center * {
|
||||||
|
text-align: center;
|
||||||
|
}
|
||||||
|
.unavailable {
|
||||||
|
text-decoration: line-through;
|
||||||
|
color: gray;
|
||||||
|
}
|
|
@ -0,0 +1,8 @@
|
||||||
|
(define-module (webui svg)
|
||||||
|
#:export (svg))
|
||||||
|
(use-modules (sxml simple))
|
||||||
|
|
||||||
|
(define (svg width height . body)
|
||||||
|
`(svg (@ (xmlns . "http://www.w3.org/2000/svg")
|
||||||
|
(viewBox ("0 0 " ,width " " ,height)))
|
||||||
|
,@body))
|
Loading…
Reference in New Issue