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