110 lines
3.8 KiB
Scheme
110 lines
3.8 KiB
Scheme
(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")
|