cco/cl-scopes
3
0
Fork 0
Code Issues 1 Pull requests Releases Wiki Activity Actions

csys/space: core functionality relevant for environ: distance, neighbors, free locations

Browse source
This commit is contained in:
Helmut Merz 2026-09-27 19:53:04 +02:00
parent 111cf87163
commit 534404d977
2 changed files with 18 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
csys/space.lisp
View file

@ -32,19 +32,26 @@
(defun neighbors (spc loc &key (dist 2)) (defun neighbors (spc loc &key (dist 2))
(let* ((range (floor (sqrt dist))) (let* ((range (floor (sqrt dist)))
nbrs) nbrs empty)
(util:with-iterator (loc-iterator range) (util:with-iterator (loc-iterator range :dist dist)
(lambda (rloc) (lambda (rloc)
(let* ((cloc (loc-add rloc loc)) (let* ((cloc (loc-add rloc loc))
(cell (fetch spc cloc))) (cell (fetch spc cloc)))
(when cell (push cell nbrs))))) (if cell
nbrs)) (push cell nbrs)
(push cloc empty)))))
(values nbrs empty)))
(defun free-loc-at (spc loc &key (dist 2))) (defun free-loc-at (spc loc &key (dist 2))
(multiple-value-bind (nbrs free) (neighbors spc loc :dist dist)
free))
(defun distance-sq (spc loc1 loc2)) (defun distance-sq (loc1 loc2)
(flet ((square (x) (* x x)))
(loop for v1 across loc1 and v2 across loc2
sum (square (- v2 v1)))))
(defun loc-iterator (range &key (dim 2)) (defun loc-iterator (range &key (dim 2) dist)
(let* ((from (- range)) (let* ((from (- range))
(zero (make-array dim :initial-element 0)) (zero (make-array dim :initial-element 0))
(cur (make-array dim :initial-element from))) (cur (make-array dim :initial-element from)))
@ -60,6 +67,8 @@
(lambda () (lambda ()
(when (equalp cur zero) (when (equalp cur zero)
(setf cur (inc cur))) (setf cur (inc cur)))
(when (and cur dist (> (distance-sq zero cur) dist))
(setf cur (inc cur)))
(when cur (when cur
(prog1 (make-array dim :initial-contents cur) (prog1 (make-array dim :initial-contents cur)
(setf cur (inc cur)))))))) (setf cur (inc cur))))))))

2
test/test-csys.lisp
View file

@ -80,6 +80,7 @@
(deftest test-space () (deftest test-space ()
(let ((spc (space:create)) (let ((spc (space:create))
locs) locs)
(== (space:distance-sq #(-1 1) #(1 2)) 5)
(space:put spc #(1 1) 42) (space:put spc #(1 1) 42)
(space:put spc #(1 2) 46) (space:put spc #(1 2) 46)
(ignore-errors (ignore-errors
@ -95,6 +96,7 @@
(== (car locs) #(1 1)) (== (car locs) #(1 1))
(== (car (last locs)) #(-1 -1)) (== (car (last locs)) #(-1 -1))
(== (car (space:neighbors spc #(1 1))) 46) (== (car (space:neighbors spc #(1 1))) 46)
(== (car (space:free-loc-at spc #(1 1))) #(2 2))
)) ))
(deftest test-basic-0 () (deftest test-basic-0 ()