124 lines
4.5 KiB
Common Lisp
124 lines
4.5 KiB
Common Lisp
(in-package :tracks)
|
|
|
|
(defparameter *dir-shared* nil)
|
|
(defparameter *conns-shared* nil)
|
|
|
|
(defstruct trackside
|
|
(:pos (error "no coordinates specified") :type aux:v3d :read-only t)
|
|
(:side (error "no side specified") :type (integer 0 15) :read-only t))
|
|
|
|
(defmacro trackside (pos side)
|
|
(alexandria:once-only
|
|
(pos side)
|
|
`(if (and ,pos ,side) (make-trackside :pos ,pos :side ,side))))
|
|
|
|
(defmethod print-object ((obj trackside) s)
|
|
(with-accessors ((p trackside-pos) (side trackside-side)) obj
|
|
(print-unreadable-object (obj s)
|
|
(format s "~a/~a" p (aref *dirnames* side)))))
|
|
|
|
(defmethod json:encode-json ((obj trackside) &optional json:*json-output*)
|
|
(with-accessors ((p trackside-pos) (side trackside-side)) obj
|
|
(json:encode-json (list (cons "p" p) (cons "s" side)))))
|
|
|
|
(defstruct dir
|
|
(:c 0 :type (integer 0 15) :read-only t)
|
|
(:r 0 :type (integer 0 1) :read-only t))
|
|
|
|
(defmethod print-object ((obj dir) s)
|
|
(print-unreadable-object (obj s)
|
|
(format s "~a~@d" (aref *dirnames* (dir-c obj)) (dir-r obj))))
|
|
|
|
(defstruct conns
|
|
(:from (error "from-field not specified for conns entry") :type dir)
|
|
(:to (error "to-field not specified for conns entry") :type dir))
|
|
|
|
(defmethod print-object ((obj conns) s)
|
|
(print-unreadable-object (obj s)
|
|
(format s "FROM ~a TO ~a" (conns-from obj) (conns-to obj))))
|
|
|
|
(defun init-shared-dirs ()
|
|
(setf *dir-shared* (make-array 32 :element-type 'dir :adjustable nil :initial-contents
|
|
(loop for i from 0 to 31 collect
|
|
(make-dir :c (ash i -1) :r (mod i 2)))))
|
|
(setf *conns-shared* (coerce (loop for i from 0 to 1023 collect
|
|
(make-conns :from (aref *dir-shared* (ash i -5))
|
|
:to (aref *dir-shared* (mod i 32))))
|
|
'(vector conns 1024))))
|
|
|
|
(defmacro dir (c &optional r shared)
|
|
(alexandria:with-gensyms (cc rc)
|
|
`(let ((,cc (the (integer 0 15) ,c)) (,rc (the (integer 0 1) (or ,r 1))))
|
|
(if ,shared (aref *dir-shared* (+ (* 2 ,cc) ,rc))
|
|
(make-dir :c ,cc :r ,rc)))))
|
|
|
|
(defmacro conns (c1 c2 &optional r1 r2 shared)
|
|
(alexandria:with-gensyms (cf ct rf rt)
|
|
`(let ((,cf (the (integer 0 15) ,c1)) (,ct (the (integer 0 15) ,c2))
|
|
(,rf (the (integer 0 1) (or ,r1 0))) (,rt (the (integer 0 1) (or ,r2 0))))
|
|
(if ,shared (aref *conns-shared* (+ (ash ,cf 6) (ash ,rf 5) (ash ,ct 1) ,rt))
|
|
(make-conns :from (dir ,c1 ,r1) :to (dir ,c2 ,r2))))))
|
|
|
|
(defmacro dirs->conns (from to &optional shared)
|
|
(alexandria:once-only
|
|
(from to)
|
|
`(if ,shared (conns (dir-c ,from) (dir-c ,to) (dir-r ,from) (dir-r ,to) t)
|
|
(make-conns :from ,from :to ,to))))
|
|
|
|
(defmacro conns-t ((c1 &body cb) (&optional r1 &body rb) &optional shared)
|
|
``(,,@(loop for c in cb and ri = rb then (cdr ri) for r = (car ri)
|
|
collect `(conns ,c1 ,c ,r1 ,r ,shared))))
|
|
|
|
(defmacro conns-x ((&body cb) (&body rb) &optional shared)
|
|
``(,,@(loop for (c1 c2) on cb by #'cddr and r = rb then (cddr rb)
|
|
for r1 = (car r) and r2 = (cadr r)
|
|
collect `(conns ,c1 ,c2 ,r1 ,r2 ,shared))))
|
|
|
|
(defmacro adjust-dir (dir diff &optional shared)
|
|
(alexandria:once-only
|
|
(dir)
|
|
`(dir (mod (+ 16 (or ,diff 0) (dir-c ,dir)) 16) (dir-r ,dir) ,shared)))
|
|
|
|
(defmacro adjust-conns (conns diff &optional shared)
|
|
(alexandria:once-only
|
|
(conns diff shared)
|
|
`(dirs->conns (adjust-dir (conns-from ,conns) ,diff ,shared)
|
|
(adjust-dir (conns-to ,conns) ,diff ,shared)
|
|
,shared)))
|
|
|
|
(defmacro adjust-conns-list (clist diff &optional shared)
|
|
(alexandria:with-gensyms (i)
|
|
(alexandria:once-only
|
|
(diff shared)
|
|
`(loop for ,i in ,clist collect (adjust-conns ,i ,diff ,shared)))))
|
|
|
|
(defmacro adjust-dir-with-param2 (dir param2 &optional shared)
|
|
`(adjust-dir ,dir (* 4 ,param2) ,shared))
|
|
|
|
(defmacro adjust-conns-with-param2 (conns param2 &optional shared)
|
|
`(adjust-conns ,conns (* 4 ,param2) ,shared))
|
|
|
|
(defmacro adjust-conns-list-with-param2 (clist param2 &optional shared)
|
|
`(adjust-conns-list ,clist (* 4 ,param2) ,shared))
|
|
|
|
(defmacro apply-dir-to-v3d (pos dir)
|
|
(alexandria:with-gensyms (h)
|
|
(alexandria:once-only
|
|
(pos dir)
|
|
`(let ((,h (aref *hdiff* (dir-c ,dir))))
|
|
(aux:make-v3d :x (+ (aux:v3d-x ,pos) (car ,h))
|
|
:y (+ (aux:v3d-y ,pos) (dir-r ,dir))
|
|
:z (+ (aux:v3d-z ,pos) (cdr ,h)))))))
|
|
|
|
(defmacro conns-list-dirs (clist)
|
|
(alexandria:with-gensyms (i)
|
|
`(remove-duplicates (loop for ,i in ,clist collect (conns-from ,i) collect (conns-to ,i))
|
|
:test #'equalp)))
|
|
|
|
(defmacro dir-length (dir)
|
|
(alexandria:with-gensyms (h)
|
|
(alexandria:once-only
|
|
(dir)
|
|
`(let ((,h (aref *hdiff* (dir-c ,dir))))
|
|
(sqrt (+ (expt (car ,h) 2) (expt (cdr ,h) 2) (expt (dir-r ,dir) 2) 0.0))))))
|