--- a/make-quickutils.lisp Thu Aug 04 21:28:08 2016 +0000
+++ b/make-quickutils.lisp Fri Aug 05 01:07:41 2016 +0000
@@ -11,6 +11,10 @@
:parse-body
; :n-grams
:define-constant
+ :hash-table-key-exists-p
+ :hash-table-keys
+ :hash-table-values
+ :map-product
; :switch
; :while
; :ensure-boolean
--- a/package.lisp Thu Aug 04 21:28:08 2016 +0000
+++ b/package.lisp Fri Aug 05 01:07:41 2016 +0000
@@ -45,7 +45,6 @@
#:cl
#:iterate
#:cl-arrows
- #:cl-ecs
#:silt.quickutils
#:silt.utils)
(:export
--- a/silt.asd Thu Aug 04 21:28:08 2016 +0000
+++ b/silt.asd Fri Aug 05 01:07:41 2016 +0000
@@ -9,8 +9,7 @@
:depends-on (#:iterate
#:cl-charms
- #:cl-arrows
- #:cl-ecs)
+ #:cl-arrows)
:serial t
:components
--- a/src/main.lisp Thu Aug 04 21:28:08 2016 +0000
+++ b/src/main.lisp Fri Aug 05 01:07:41 2016 +0000
@@ -52,6 +52,9 @@
*screen-center-y* (floor h 2))))
+(defun symbolize (&rest args)
+ (intern (format nil "~{~A~}" args)))
+
(defmacro render (&body body)
`(prog2
(progn
@@ -225,9 +228,9 @@
(defun terrain-type (x y)
(let ((h (aref *heightmap* (wrap x) (wrap y))))
- (cond ((< h 0.2) :deep-water)
+ (cond ((< h 0.23) :deep-water)
((< h 0.3) :shallow-water)
- ((< h 0.32) :sand)
+ ((< h 0.34) :sand)
((< h 0.65) :grass)
((< h 0.7) :dirt)
((< h 0.75) :hills)
@@ -256,31 +259,133 @@
(< -1 sy *screen-height*)))
+;;;; Roll-Your-Own-ECS
+;;; Entities are stored in an {id -> entity} hash table.
+;;;
+;;; Entities are also indexed by component in a nested hash table:
+;;;
+;;; {component-symbol -> {id -> entity}}
+;;;
+;;; Systems are stored as:
+;;;
+;;; {system-symbol -> (cons system-function type-specifier-list)}
+(defvar *entity-id-counter* 0)
+(defvar *entity-index* (make-hash-table))
+(defvar *component-index* (make-hash-table))
+(defvar *system-index* (make-hash-table))
+
+
+(defun clear-entities ()
+ (clrhash *entity-index*)
+ (mapc #'clrhash (hash-table-values *component-index*)))
+
+(defun get-entity (id)
+ (gethash *entity-index* id))
+
+
+(defclass entity ()
+ ((id :reader entity-id :initform (incf *entity-id-counter*))))
+
+(defmethod initialize-instance :after ((e entity) &key)
+ (setf (gethash (entity-id e) *entity-index*) e))
+
+
+(defmacro define-entity (name components &rest slots)
+ `(defclass ,name (entity ,@components)
+ (,@slots)))
+
+
+(defun initialize-component-index (name)
+ (unless (hash-table-key-exists-p *component-index* name)
+ (setf (gethash name *component-index*)
+ (make-hash-table))))
+
+(defmacro define-component (name &rest fields)
+ (flet ((clean-field (f)
+ (etypecase f
+ (symbol (list f))
+ (list f))))
+ `(progn
+ (defclass ,name ()
+ ,(iterate
+ (for (field . field-options) :in (mapcar #'clean-field fields))
+ (for field-name = (symbolize name '/ field))
+ (collect `(,field-name
+ :accessor ,field-name
+ :initarg ,(intern (symbol-name field-name) "KEYWORD")
+ ,@field-options))))
+
+ (initialize-component-index ',name)
+
+ (defmethod initialize-instance :after ((o ,name) &key)
+ (setf (gethash (entity-id o)
+ (gethash ',name *component-index*))
+ o))
+
+ (find-class ',name))))
+
+
+(defmacro define-system (name arglist &body body)
+ `(prog1
+ (declaim (ftype (function
+ (,@(mapcar (lambda (arg)
+ `(and entity ,@(cdr arg)))
+ arglist))
+ (values null &optional))
+ ,name))
+ (defun ,name (,@(mapcar #'car arglist))
+ ,@body
+ nil)
+ (setf (gethash ',name *system-index*) (cons #',name ',(mapcar #'cdr arglist)))))
+
+(defun run-system (system)
+ (flet ((retrieve-entities (specifier)
+ (if (null specifier)
+ (hash-table-values *entity-index*)
+ (apply #'intersection
+ (mapcar (lambda (component)
+ (hash-table-values
+ (gethash component *component-index*)))
+ specifier)))))
+ (destructuring-bind (system-function . type-specifiers)
+ (gethash system *system-index*)
+ (apply #'map-product system-function
+ (mapcar #'retrieve-entities type-specifiers))
+ (values))))
+
+
;;;; ECS
-(init-ecs)
-
;;; Components
-(defcomponent coords
- (x y))
+(define-component coords x y)
-(defcomponent visible
- (glyph color))
+(define-component visible
+ (glyph :type char)
+ color)
;;; Entities
+(define-entity tree (coords visible))
+(define-entity algae (coords visible edible))
+
+
(defun make-tree (x y)
- (add-entity nil
- (coords :x x :y y)
- (visible :glyph #\T :color +color-green+)))
+ (make-instance 'tree
+ :coords/x x
+ :coords/y y
+ :visible/glyph #\T
+ :visible/color +color-green+))
(defun make-algae (x y)
- (add-entity nil
- (coords :x x :y y)
- (visible :glyph #\` :color +color-green+)))
+ (make-instance 'algae
+ :coords/x x
+ :coords/y y
+ :edible/energy 10
+ :visible/glyph #\`
+ :visible/color +color-green+))
;;; Systems
-(defsys draw-visible ((visible coords) (entity))
+(define-system draw-visible ((entity visible coords))
(multiple-value-bind (sx sy)
(world-to-screen (coords/x entity) (coords/y entity))
(when (onscreenp sx sy)
@@ -290,9 +395,6 @@
(visible/glyph entity)
sx sy)))))
-(defsys clear-entities (() (entity))
- (remove-entity entity))
-
;;;; Flora
(defun tree-probability (x y)
@@ -396,7 +498,7 @@
(defun render-map ()
(draw-terrain)
- (do-system 'draw-visible)
+ (run-system 'draw-visible)
(draw-ui))
@@ -446,7 +548,7 @@
(defun state-generate ()
(render-generate)
- (do-system 'clear-entities)
+ (clear-entities)
(setf *heightmap* (diamond-square (allocate-heightmap))
*view-x* 0
*view-y* 0)
--- a/vendor/quickutils.lisp Thu Aug 04 21:28:08 2016 +0000
+++ b/vendor/quickutils.lisp Fri Aug 05 01:07:41 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "vendor/quickutils.lisp" :utilities '(:WITH-GENSYMS :ONCE-ONLY :COMPOSE :CURRY :RCURRY :PARSE-BODY :DEFINE-CONSTANT) :ensure-package T :package "SILT.QUICKUTILS")
+;;;; (qtlc:save-utils-as "vendor/quickutils.lisp" :utilities '(:WITH-GENSYMS :ONCE-ONLY :COMPOSE :CURRY :RCURRY :PARSE-BODY :DEFINE-CONSTANT :HASH-TABLE-KEY-EXISTS-P :HASH-TABLE-KEYS :HASH-TABLE-VALUES :MAP-PRODUCT) :ensure-package T :package "SILT.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "SILT.QUICKUTILS")
@@ -16,7 +16,11 @@
(setf *utilities* (union *utilities* '(:STRING-DESIGNATOR :WITH-GENSYMS
:MAKE-GENSYM-LIST :ONCE-ONLY
:ENSURE-FUNCTION :COMPOSE :CURRY
- :RCURRY :PARSE-BODY :DEFINE-CONSTANT))))
+ :RCURRY :PARSE-BODY :DEFINE-CONSTANT
+ :HASH-TABLE-KEY-EXISTS-P :MAPHASH-KEYS
+ :HASH-TABLE-KEYS :MAPHASH-VALUES
+ :HASH-TABLE-VALUES :MAPPEND
+ :MAP-PRODUCT))))
(deftype string-designator ()
"A string designator type. A string designator is either a string, a symbol,
@@ -241,8 +245,78 @@
`(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test)
,@(when documentation `(,documentation))))
+
+ (defun hash-table-key-exists-p (hash-table key)
+ "Does `key` exist in `hash-table`?"
+ (nth-value 1 (gethash key hash-table)))
+
+
+ (declaim (inline maphash-keys))
+ (defun maphash-keys (function table)
+ "Like `maphash`, but calls `function` with each key in the hash table `table`."
+ (maphash (lambda (k v)
+ (declare (ignore v))
+ (funcall function k))
+ table))
+
+
+ (defun hash-table-keys (table)
+ "Returns a list containing the keys of hash table `table`."
+ (let ((keys nil))
+ (maphash-keys (lambda (k)
+ (push k keys))
+ table)
+ keys))
+
+
+ (declaim (inline maphash-values))
+ (defun maphash-values (function table)
+ "Like `maphash`, but calls `function` with each value in the hash table `table`."
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (funcall function v))
+ table))
+
+
+ (defun hash-table-values (table)
+ "Returns a list containing the values of hash table `table`."
+ (let ((values nil))
+ (maphash-values (lambda (v)
+ (push v values))
+ table)
+ values))
+
+
+ (defun mappend (function &rest lists)
+ "Applies `function` to respective element(s) of each `list`, appending all the
+all the result list to a single list. `function` must return a list."
+ (loop for results in (apply #'mapcar function lists)
+ append results))
+
+
+ (defun map-product (function list &rest more-lists)
+ "Returns a list containing the results of calling `function` with one argument
+from `list`, and one from each of `more-lists` for each combination of arguments.
+In other words, returns the product of `list` and `more-lists` using `function`.
+
+Example:
+
+ (map-product 'list '(1 2) '(3 4) '(5 6))
+ => ((1 3 5) (1 3 6) (1 4 5) (1 4 6)
+ (2 3 5) (2 3 6) (2 4 5) (2 4 6))"
+ (labels ((%map-product (f lists)
+ (let ((more (cdr lists))
+ (one (car lists)))
+ (if (not more)
+ (mapcar f one)
+ (mappend (lambda (x)
+ (%map-product (curry f x) more))
+ one)))))
+ (%map-product (ensure-function function) (cons list more-lists))))
+
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(with-gensyms with-unique-names once-only compose curry rcurry
- parse-body define-constant)))
+ parse-body define-constant hash-table-key-exists-p hash-table-keys
+ hash-table-values map-product)))
;;;; END OF vendor/quickutils.lisp ;;;;