# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1470359261 0
# Node ID 674116652382dde755b11b9facdadf33277eee02
# Parent  a023f4963a1eecf674100d72c9b585552b22eade
NIH

diff -r a023f4963a1e -r 674116652382 make-quickutils.lisp
--- 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
diff -r a023f4963a1e -r 674116652382 package.lisp
--- 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
diff -r a023f4963a1e -r 674116652382 silt.asd
--- 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
diff -r a023f4963a1e -r 674116652382 src/main.lisp
--- 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)
diff -r a023f4963a1e -r 674116652382 vendor/quickutils.lisp
--- 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 ;;;;