--- a/.lispwords Thu Aug 04 20:19:27 2016 +0000
+++ b/.lispwords Thu Aug 04 21:28:08 2016 +0000
@@ -2,3 +2,4 @@
(1 recursively)
(2 state-machine)
(1 with-color)
+(1 add-entity)
--- a/package.lisp Thu Aug 04 20:19:27 2016 +0000
+++ b/package.lisp Thu Aug 04 21:28:08 2016 +0000
@@ -45,6 +45,7 @@
#:cl
#:iterate
#:cl-arrows
+ #:cl-ecs
#:silt.quickutils
#:silt.utils)
(:export
--- a/silt.asd Thu Aug 04 20:19:27 2016 +0000
+++ b/silt.asd Thu Aug 04 21:28:08 2016 +0000
@@ -9,7 +9,8 @@
:depends-on (#:iterate
#:cl-charms
- #:cl-arrows)
+ #:cl-arrows
+ #:cl-ecs)
:serial t
:components
--- a/src/main.lisp Thu Aug 04 20:19:27 2016 +0000
+++ b/src/main.lisp Thu Aug 04 21:28:08 2016 +0000
@@ -10,7 +10,7 @@
(defparameter *screen-center-x* 1)
(defparameter *screen-center-y* 1)
-(defparameter *world-exponent* 10)
+(defparameter *world-exponent* 9)
(defparameter *world-size* (expt 2 *world-exponent*))
(defparameter *view-x* 0)
@@ -93,6 +93,27 @@
(for ty :from y)
(write-string-at string tx ty)))))
+(defun write-right (text x y)
+ (etypecase text
+ (string (write-right (list text) x y))
+ (list (iterate
+ (for string :in text)
+ (for tx = (- x (length string)))
+ (for ty :from y)
+ (write-string-at string tx ty)))))
+
+
+(defun l (s &rest args)
+ (write-centered (apply #'format nil s args)
+ *screen-center-x* *screen-center-y*))
+
+
+(defclause-sequence ACROSS-FLAT-ARRAY INDEX-OF-FLAT-ARRAY
+ :access-fn 'row-major-aref
+ :size-fn 'array-total-size
+ :sequence-type 'array
+ :element-type t)
+
;;;; World Generation
(defun jitter (value spread)
@@ -194,24 +215,113 @@
heightmap)
-;;;;
+;;;; Miscellaneous
(defun move-view (dx dy)
- (incf *view-x* dx)
- (incf *view-y* dy))
+ (setf *view-x* (wrap (+ *view-x* dx))
+ *view-y* (wrap (+ *view-y* dy))))
(defun wrap (coord)
(mod coord *world-size*))
-(defun terrain-char (x y)
+(defun terrain-type (x y)
(let ((h (aref *heightmap* (wrap x) (wrap y))))
- (cond ((< h 0.2) (values #\~ +color-blue+))
- ((< h 0.3) (values #\~ +color-cyan+))
- ((< h 0.32) (values #\: +color-yellow+))
- ((< h 0.65) (values #\. +color-green+))
- ((< h 0.7) (values #\. +color-white+))
- ((< h 0.75) (values #\^ +color-white+))
- ((< h 0.9) (values #\# +color-white+))
- (t (values #\* +color-snow+)))))
+ (cond ((< h 0.2) :deep-water)
+ ((< h 0.3) :shallow-water)
+ ((< h 0.32) :sand)
+ ((< h 0.65) :grass)
+ ((< h 0.7) :dirt)
+ ((< h 0.75) :hills)
+ ((< h 0.9) :mountain)
+ (t :snow))))
+
+(defun terrain-char (x y)
+ (case (terrain-type x y)
+ (:deep-water (values #\~ +color-blue+))
+ (:shallow-water (values #\~ +color-cyan+))
+ (:sand (values #\: +color-yellow+))
+ (:grass (values #\. +color-green+))
+ (:dirt (values #\. +color-white+))
+ (:hills (values #\^ +color-white+))
+ (:mountain (values #\# +color-white+))
+ (:snow (values #\* +color-snow+))))
+
+(defun world-to-screen (wx wy)
+ "Convert world-space coordinates to screen-space."
+ (values (- wx *view-x*)
+ (- wy *view-y*)))
+
+(defun onscreenp (sx sy)
+ "Return whether the given screen-space coords are visible in the viewport."
+ (and (< -1 sx *screen-width*)
+ (< -1 sy *screen-height*)))
+
+
+;;;; ECS
+(init-ecs)
+
+;;; Components
+(defcomponent coords
+ (x y))
+
+(defcomponent visible
+ (glyph color))
+
+
+;;; Entities
+(defun make-tree (x y)
+ (add-entity nil
+ (coords :x x :y y)
+ (visible :glyph #\T :color +color-green+)))
+
+(defun make-algae (x y)
+ (add-entity nil
+ (coords :x x :y y)
+ (visible :glyph #\` :color +color-green+)))
+
+
+;;; Systems
+(defsys draw-visible ((visible coords) (entity))
+ (multiple-value-bind (sx sy)
+ (world-to-screen (coords/x entity) (coords/y entity))
+ (when (onscreenp sx sy)
+ (with-color (visible/color entity)
+ (charms:write-char-at-point
+ charms:*standard-window*
+ (visible/glyph entity)
+ sx sy)))))
+
+(defsys clear-entities (() (entity))
+ (remove-entity entity))
+
+
+;;;; Flora
+(defun tree-probability (x y)
+ (case (terrain-type x y)
+ (:grass 0.01)
+ (:dirt 0.001)
+ (t 0)))
+
+(defun algae-probability (x y)
+ (case (terrain-type x y)
+ (:shallow-water 0.01)
+ (:deep-water 0.001)
+ (t 0)))
+
+(defun grow-trees ()
+ (iterate
+ (for x :from 0 :below *world-size*)
+ (iterate
+ (for y :from 0 :below *world-size*)
+ (when (< (random 1.0) (tree-probability x y))
+ (make-tree x y)))))
+
+(defun grow-algae ()
+ (iterate
+ (for x :from 0 :below *world-size*)
+ (iterate
+ (for y :from 0 :below *world-size*)
+ (when (< (random 1.0) (algae-probability x y))
+ (make-algae x y)))))
;;;; Game State Machine
@@ -262,7 +372,8 @@
(write-centered "Generating world, please wait..."
*screen-center-x* *screen-center-y*)))
-(defun render-map ()
+
+(defun draw-terrain ()
(iterate
(repeat *screen-width*)
(for sx :from 0)
@@ -278,6 +389,16 @@
char
sx sy)))))
+(defun draw-ui ()
+ (write-right (format nil "[~D, ~D]" *view-x* *view-y*)
+ (1- *screen-width*) 0))
+
+
+(defun render-map ()
+ (draw-terrain)
+ (do-system 'draw-visible)
+ (draw-ui))
+
(defun press-any-key ()
(charms:disable-non-blocking-mode charms:*standard-window*)
@@ -325,7 +446,12 @@
(defun state-generate ()
(render-generate)
- (setf *heightmap* (diamond-square (allocate-heightmap)))
+ (do-system 'clear-entities)
+ (setf *heightmap* (diamond-square (allocate-heightmap))
+ *view-x* 0
+ *view-y* 0)
+ (grow-trees)
+ (grow-algae)
(state-map))
(defun state-map ()