80 lines
2.4 KiB
Common Lisp
80 lines
2.4 KiB
Common Lisp
;;;; cl-scopes/csys/space
|
|
;;;; definitions for (spatial) registering and retrieving objects by location
|
|
|
|
(defpackage :scopes/csys/space
|
|
(:use :common-lisp)
|
|
(:local-nicknames (:alx :alexandria)
|
|
(:util :scopes/util))
|
|
(:export #:create #:put #:del #:fetch #:query
|
|
#:neighbors #:free-loc-at #:distance-sq
|
|
#:loc-iterator))
|
|
|
|
(in-package :scopes/csys/space)
|
|
|
|
(defun create ()
|
|
(make-hash-table :test #'equalp))
|
|
|
|
(defun put (spc loc obj)
|
|
(let ((current (gethash loc spc)))
|
|
(if current
|
|
(error "location already occupied! space: ~s, loc: ~s, current: ~s, new: ~s"
|
|
spc loc current obj)
|
|
(setf (gethash loc spc) obj))))
|
|
|
|
(defun del (spc loc)
|
|
(remhash loc spc))
|
|
|
|
(defun fetch (spc loc)
|
|
(gethash loc spc))
|
|
|
|
(defun query (spc pattern)
|
|
nil)
|
|
|
|
(defun neighbors (spc loc &key (dist 2))
|
|
(let* ((range (floor (sqrt dist)))
|
|
nbrs empty)
|
|
(util:with-iterator (loc-iterator range :dist dist)
|
|
(lambda (rloc)
|
|
(let* ((cloc (loc-add rloc loc))
|
|
(cell (fetch spc cloc)))
|
|
(if cell
|
|
(push cell nbrs)
|
|
(push cloc empty)))))
|
|
(values nbrs empty)))
|
|
|
|
(defun free-loc-at (spc loc &key (dist 2))
|
|
(multiple-value-bind (nbrs free) (neighbors spc loc :dist dist)
|
|
free))
|
|
|
|
(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) dist)
|
|
(let* ((from (- range))
|
|
(zero (make-array dim :initial-element 0))
|
|
(cur (make-array dim :initial-element from)))
|
|
(labels (
|
|
(inc (cur &optional (idx 0))
|
|
(when (< idx dim)
|
|
(let ((new (1+ (aref cur idx))))
|
|
(setf (aref cur idx) new)
|
|
(when (> new range)
|
|
(setf (aref cur idx) from)
|
|
(setf cur (inc cur (1+ idx))))
|
|
cur))))
|
|
(lambda ()
|
|
(when (equalp cur zero)
|
|
(setf cur (inc cur)))
|
|
(when (and cur dist (> (distance-sq zero cur) dist))
|
|
(setf cur (inc cur)))
|
|
(when cur
|
|
(prog1 (make-array dim :initial-contents cur)
|
|
(setf cur (inc cur))))))))
|
|
|
|
(defun loc-add (l1 l2)
|
|
(let* ((dim (car (array-dimensions l1)))
|
|
(loc (make-array dim :initial-contents l1)))
|
|
(loop for i to (1- dim) do (setf (aref loc i) (+ (aref l1 i) (aref l2 i))))
|
|
loc))
|