--- a/package.lisp Fri Aug 05 16:15:43 2016 +0000
+++ b/package.lisp Fri Aug 05 23:48:38 2016 +0000
@@ -1,54 +1,9 @@
-(defpackage #:silt.utils
- (:use
- #:cl
- #:iterate
- #:cl-arrows
- #:silt.quickutils)
- (:export
- #:zap%
- #:%
- #:recursively
- #:recur
- #:dis
- #:spit
- #:d
- #:clamp
- #:symbolize
- #:random-range
- #:random-around
-
- #:dlambda
-
- #:hash-set
- #:make-set
- #:set-contains-p
- #:set-add
- #:set-remove
- #:set-add-all
- #:set-remove-all
- #:set-random
- #:set-pop
- #:set-empty-p
- #:set-clear
-
- #:averaging
- #:timing
- #:real-time
- #:run-time
- #:since-start-into
- #:per-iteration-into
- #:in-whatever
-
- )
- (:shadowing-import-from #:cl-arrows
- #:->))
-
(defpackage #:silt
(:use
#:cl
#:iterate
#:cl-arrows
- #:silt.quickutils
- #:silt.utils)
+ #:losh
+ #:silt.quickutils)
(:export
#:main))
--- a/silt.asd Fri Aug 05 16:15:43 2016 +0000
+++ b/silt.asd Fri Aug 05 23:48:38 2016 +0000
@@ -10,7 +10,8 @@
:depends-on (#:iterate
#:cl-charms
#:cl-arrows
- #:sb-sprof)
+ #:sb-sprof
+ #:losh)
:serial t
:components
@@ -18,7 +19,4 @@
:serial t
:components ((:file "quickutils")))
(:file "package")
- (:module "src"
- :serial t
- :components ((:file "utils")
- (:file "main")))))
+ (:file "silt")))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/silt.lisp Fri Aug 05 23:48:38 2016 +0000
@@ -0,0 +1,811 @@
+(in-package #:silt)
+(require :sb-sprof)
+
+;;;; Data
+(defparameter *running* nil)
+(defparameter *running* t)
+(defparameter *debug* nil)
+
+(defparameter *screen-width* 1)
+(defparameter *screen-height* 1)
+(defparameter *screen-center-x* 1)
+(defparameter *screen-center-y* 1)
+
+(define-constant +world-exponent+ 9)
+(define-constant +world-size+ (expt 2 +world-exponent+))
+
+(defparameter *view-x* 0)
+(defparameter *view-y* 0)
+
+(defparameter *cursor-x* 0)
+(defparameter *cursor-y* 0)
+
+(deftype world-coordinate ()
+ `(integer 0 ,(1- +world-size+)))
+
+(deftype world-array ()
+ `(simple-array single-float (,+world-size+ ,+world-size+)))
+
+(defun allocate-heightmap ()
+ (make-array (list +world-size+ +world-size+)
+ :element-type 'single-float
+ :initial-element 0.0
+ :adjustable nil))
+
+(defvar *heightmap* (allocate-heightmap))
+
+(declaim (type world-array *heightmap*))
+
+
+;;;; Colors
+(define-constant +color-white+ 0)
+(define-constant +color-blue+ 1)
+(define-constant +color-yellow+ 2)
+(define-constant +color-cyan+ 3)
+(define-constant +color-snow+ 4)
+(define-constant +color-green+ 5)
+(define-constant +color-pink+ 6)
+
+(defun init-colors ()
+ (charms/ll:init-pair +color-white+ charms/ll:COLOR_WHITE charms/ll:COLOR_BLACK)
+ (charms/ll:init-pair +color-blue+ charms/ll:COLOR_BLUE charms/ll:COLOR_BLACK)
+ (charms/ll:init-pair +color-yellow+ charms/ll:COLOR_YELLOW charms/ll:COLOR_BLACK)
+ (charms/ll:init-pair +color-cyan+ charms/ll:COLOR_CYAN charms/ll:COLOR_BLACK)
+ (charms/ll:init-pair +color-snow+ charms/ll:COLOR_BLACK charms/ll:COLOR_WHITE)
+ (charms/ll:init-pair +color-green+ charms/ll:COLOR_GREEN charms/ll:COLOR_BLACK)
+ (charms/ll:init-pair +color-pink+ charms/ll:COLOR_MAGENTA charms/ll:COLOR_BLACK))
+
+(defmacro with-color (color &body body)
+ (once-only (color)
+ `(unwind-protect
+ (prog2
+ (charms/ll:attron (charms/ll:color-pair ,color))
+ (progn ,@body))
+ (charms/ll:attroff (charms/ll:color-pair ,color)))))
+
+
+;;;; Utils
+(defun manage-screen ()
+ (multiple-value-bind (w h)
+ (charms:window-dimensions charms:*standard-window*)
+ (setf *screen-width* (1- w) *screen-height* (1- h)
+ *screen-center-x* (floor w 2)
+ *screen-center-y* (floor h 2))))
+
+(defmacro render (&body body)
+ `(prog2
+ (progn
+ (manage-screen)
+ (charms:clear-window charms:*standard-window*))
+ (progn ,@body)
+ (charms:refresh-window charms:*standard-window*)))
+
+(defun clamp-w (x)
+ (clamp 0 (1- *screen-width*) x))
+
+(defun clamp-h (y)
+ (clamp 0 (1- *screen-height*) y))
+
+
+(defun write-string-at (string x y)
+ (charms:write-string-at-point
+ charms:*standard-window*
+ string
+ (clamp-w x)
+ (clamp-h y)))
+
+
+(defun write-centered (text x y)
+ (etypecase text
+ (string (write-centered (list text) x y))
+ (list (iterate
+ (for string :in text)
+ (for tx = (- x (floor (length string) 2)))
+ (for ty :from y)
+ (write-string-at string tx ty)))))
+
+(defun write-left (text x y)
+ (etypecase text
+ (string (write-left (list text) x y))
+ (list (iterate
+ (for string :in text)
+ (for tx = x)
+ (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)
+ (+ value (- (random (* 2.0 spread))
+ spread)))
+
+(defun average (&rest values)
+ (/ (apply #'+ values) (length values)))
+
+
+
+
+(defun hm-size (heightmap)
+ (first (array-dimensions heightmap)))
+
+(defun hm-ref (heightmap x y)
+ (let ((last (hm-size heightmap)))
+ (aref heightmap
+ (cond
+ ((< -1 x last) x)
+ ((= x last) 0)
+ (t (mod x last)))
+ (cond
+ ((< -1 y last) y)
+ ((= y last) 0)
+ (t (mod y last))))))
+
+
+(defun normalize-heightmap (heightmap)
+ (iterate
+ (for i :from 0 :below (array-total-size heightmap))
+ (for v = (row-major-aref heightmap i))
+ (maximize v :into max)
+ (minimize v :into min)
+ (finally
+ (iterate
+ (with span = (- max min))
+ (for i :from 0 :below (array-total-size heightmap))
+ (for v = (row-major-aref heightmap i))
+ (setf (row-major-aref heightmap i)
+ (/ (- v min) span))))))
+
+
+(defun ds-init (heightmap)
+ (setf (aref heightmap 0 0) 0.5))
+
+
+(defun ds-square (heightmap x y radius spread)
+ (setf (aref heightmap x y)
+ (jitter (average (hm-ref heightmap (- x radius) (- y radius))
+ (hm-ref heightmap (- x radius) (+ y radius))
+ (hm-ref heightmap (+ x radius) (- y radius))
+ (hm-ref heightmap (+ x radius) (+ y radius)))
+ spread)))
+
+(defun ds-diamond (heightmap x y radius spread)
+ (setf (aref heightmap x y)
+ (jitter (average (hm-ref heightmap (- x radius) y)
+ (hm-ref heightmap (+ x radius) y)
+ (hm-ref heightmap x (- y radius))
+ (hm-ref heightmap x (+ y radius)))
+ spread)))
+
+
+(defun ds-squares (heightmap radius spread)
+ (iterate
+ (for x :from radius :below (hm-size heightmap) :by (* 2 radius))
+ (iterate
+ (for y :from radius :below (hm-size heightmap) :by (* 2 radius))
+ (ds-square heightmap x y radius spread))))
+
+(defun ds-diamonds (heightmap radius spread)
+ (iterate
+ (for i :from 0)
+ (for y :from 0 :below (hm-size heightmap) :by radius)
+ (for shift = (if (evenp i) radius 0))
+ (iterate
+ (for x :from shift :below (hm-size heightmap) :by (* 2 radius))
+ (ds-diamond heightmap x y radius spread))))
+
+
+(defun diamond-square (heightmap)
+ (ds-init heightmap)
+ (let ((spread 0.7)
+ (spread-reduction 0.6))
+ (recursively ((radius (floor (hm-size heightmap) 2))
+ (spread spread))
+ (when (>= radius 1)
+ (ds-squares heightmap radius spread)
+ (ds-diamonds heightmap radius spread)
+ (recur (/ radius 2)
+ (* spread spread-reduction)))))
+ (normalize-heightmap heightmap)
+ heightmap)
+
+
+;;;; Miscellaneous
+(declaim (inline wrap)
+ (ftype (function (fixnum) world-coordinate) wrap)
+ (ftype (function (fixnum fixnum)) terrain-type terrain-char))
+
+(defun wrap (coord)
+ (mod coord +world-size+))
+
+(defun move-view (dx dy)
+ (setf *view-x* (wrap (+ *view-x* dx))
+ *view-y* (wrap (+ *view-y* dy))))
+
+(defun move-cursor (dx dy)
+ (setf *cursor-x* (clamp-w (+ *cursor-x* dx))
+ *cursor-y* (clamp-h (+ *cursor-y* dy))))
+
+
+(defun terrain-type (x y)
+ (let ((h (aref *heightmap* (wrap x) (wrap y))))
+ (cond ((< h 0.23) :deep-water)
+ ((< h 0.3) :shallow-water)
+ ((< h 0.34) :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 (wrap (- wx *view-x*))
+ (wrap (- wy *view-y*))))
+
+(defun screen-to-world (sx sy)
+ "Convert screen-space coordinates to world-space."
+ (values (wrap (+ sx *view-x*))
+ (wrap (+ sy *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*)))
+
+
+;;;; 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}}
+;;;
+;;; Entities are indexed by system too:
+;;;
+;;; {system-symbol ->
+;;; ({id -> entity} ; arg1
+;;; {id -> entity}) ; arg2
+;;; }
+;;;
+;;; Systems are stored as:
+;;;
+;;; {system-symbol -> (cons system-function type-specifier-list)}
+;;;
+;;; TODO: Figure out the distinct problem.
+
+(defvar *entity-id-counter* 0)
+(defvar *entity-index* (make-hash-table))
+(defvar *component-index* (make-hash-table))
+(defvar *systems* (make-hash-table))
+(defvar *system-index* (make-hash-table))
+
+
+(defun clear-entities ()
+ (mapc #'destroy-entity (hash-table-values *entity-index*)))
+
+(defun get-entity (id)
+ (gethash id *entity-index*))
+
+
+(defun index-entity (e)
+ (setf (gethash (entity-id e) *entity-index*) e))
+
+(defun satisfies-system-type-specifier-p (entity specifier)
+ (every (lambda (component) (typep entity component))
+ specifier))
+
+(defun index-entity-systems (e)
+ (iterate
+ (for (system (function . type-specifiers)) :in-hashtable *systems*)
+ (iterate
+ (for argument-index :in (gethash system *system-index*))
+ (for specifier :in type-specifiers)
+ (when (satisfies-system-type-specifier-p e specifier)
+ (setf (gethash (entity-id e) argument-index) e)))))
+
+
+(defclass entity ()
+ ((id :reader entity-id :initform (incf *entity-id-counter*))))
+
+(defmethod print-object ((e entity) stream)
+ (print-unreadable-object (e stream :type t :identity nil)
+ (format stream "~D" (entity-id e))))
+
+(defmethod initialize-instance :after ((e entity) &key)
+ (index-entity e)
+ (index-entity-systems e))
+
+
+(defgeneric entity-created (entity)
+ (:method ((entity entity)) nil))
+
+(defgeneric entity-destroyed (entity)
+ (:method ((entity entity)) nil))
+
+
+(defun create-entity (class &rest initargs)
+ (let ((entity (apply #'make-instance class initargs)))
+ (entity-created entity)
+ entity))
+
+(defun destroy-entity (entity)
+ (let ((id (entity-id entity)))
+ (remhash id *entity-index*)
+ (iterate
+ (for (nil index) :in-hashtable *component-index*)
+ (remhash id index))
+ (iterate
+ (for (nil argument-indexes) :in-hashtable *system-index*)
+ (iterate (for index :in argument-indexes)
+ (remhash id index))))
+ (entity-destroyed entity)
+ nil)
+
+
+(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)
+ `(progn
+ (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 *systems*)
+ (cons #',name ',(mapcar #'cdr arglist))
+ (gethash ',name *system-index*)
+ (list ,@(iterate (repeat (length arglist))
+ (collect `(make-hash-table)))))
+ ',name))
+
+(defun run-system (system)
+ (destructuring-bind (system-function . type-specifiers)
+ (gethash system *systems*)
+ (declare (ignore type-specifiers))
+ (apply #'map-product system-function
+ (mapcar #'hash-table-values (gethash system *system-index*)))
+ (values)))
+
+
+;;;; Coordinates
+(define-component coords x y)
+
+
+(defparameter *coords-contents* (make-hash-table))
+
+
+(defun coordinate-key (x y)
+ (array-row-major-index *heightmap* (wrap x) (wrap y)))
+
+(defun coordinate-key-for-entity (e)
+ (coordinate-key (coords/x e) (coords/y e)))
+
+
+(defun coords-insert-entity (e)
+ (push e (gethash (coordinate-key-for-entity e) *coords-contents*)))
+
+(defun coords-remove-entity (e)
+ (let ((k (coordinate-key-for-entity e)))
+ (when (null (zap% (gethash k *coords-contents*)
+ #'delete e %))
+ (remhash k *coords-contents*))))
+
+(defun coords-move-entity (e new-x new-y)
+ (coords-remove-entity e)
+ (setf (coords/x e) new-x
+ (coords/y e) new-y)
+ (coords-insert-entity e))
+
+(defun coords-lookup (x y)
+ (gethash (coordinate-key x y) *coords-contents*))
+
+
+(defmethod entity-created :after ((entity coords))
+ (coords-insert-entity entity))
+
+(defmethod entity-destroyed :after ((entity coords))
+ (coords-remove-entity entity))
+
+
+;;;; Flavor Text
+(define-component flavor text)
+
+;;; Components
+(define-component visible
+ (glyph :type string)
+ color)
+
+(define-component edible
+ energy)
+
+(define-component fruiting
+ chance)
+
+
+;;; Entities
+(define-entity fruit (coords visible edible flavor))
+(define-entity tree (coords visible fruiting flavor))
+(define-entity algae (coords visible edible))
+
+(defun make-tree (x y)
+ (create-entity 'tree
+ :coords/x x
+ :coords/y y
+ :visible/glyph "T"
+ :visible/color +color-green+
+ :fruiting/chance 0.0001
+ :flavor/text "A tree sways gently in the wind."))
+
+(defun make-fruit (x y)
+ (create-entity 'fruit
+ :coords/x x
+ :coords/y y
+ :visible/glyph "ó"
+ :visible/color +color-pink+
+ :edible/energy (random-around 10 3)
+ :flavor/text "A ripe piece of fruit has fallen to the ground."))
+
+(defun make-algae (x y)
+ (create-entity 'algae
+ :coords/x x
+ :coords/y y
+ :visible/glyph "`"
+ :visible/color +color-green+))
+
+
+;;; Systems
+
+(define-system grow-fruit ((entity fruiting coords))
+ (when (< (random 1.0) (fruiting/chance entity))
+ (make-fruit (wrap (random-around (coords/x entity) 2))
+ (wrap (random-around (coords/y entity) 2)))))
+
+
+;;;; 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)))))
+
+
+
+;;;; Profiling
+(sb-sprof::profile-call-counts "SILT")
+(defvar *profiling* nil)
+
+(defun dump-profile ()
+ (with-open-file (*standard-output* "silt.prof"
+ :direction :output
+ :if-exists :supersede)
+ (sb-sprof:report :type :graph
+ :sort-by :cumulative-samples
+ :sort-order :ascending)
+ (sb-sprof:report :type :flat
+ :min-percent 0.5)))
+
+(defun start-profiling ()
+ (sb-sprof::reset)
+ (sb-sprof::start-profiling :max-samples 50000
+ :mode :cpu
+ :sample-interval 0.005
+ :threads :all)
+ (setf *profiling* t))
+
+(defun stop-profiling ()
+ (setf *profiling* nil)
+ (sb-sprof::stop-profiling)
+ (dump-profile))
+
+
+;;;; Game State Machine
+(defun render-title ()
+ (render
+ (write-centered '("S I L T"
+ ""
+ "Press any key to start...")
+ *screen-center-x*
+ (1- *screen-center-y*))))
+
+(defun render-intro ()
+ (render
+ (write-left '("Welcome to Silt."
+ ""
+ "You are the god of a toroidal world."
+ ""
+ "CONTROLS"
+ " hjklyubn - move your view"
+ " HJKLYUBN - move your view faster"
+ ""
+ " wasd - move your cursor"
+ " WASD - move your cursor faster"
+ ""
+ " Q - quit"
+ " R - regenerate the world"
+ ""
+ " ? - help"
+ ""
+ "Press any key to begin."
+ )
+ 1 1)))
+
+(defun render-help ()
+ (render
+ (write-left '("CONTROLS"
+ " hjklyubn - move your view"
+ " HJKLYUBN - move your view faster"
+ ""
+ " wasd - move your cursor"
+ " WASD - move your cursor faster"
+ ""
+ " Q - quit"
+ " R - regenerate the world"
+ ""
+ " ? - help"
+ ""
+ "Press any key to continue."
+ )
+ 1 1)))
+
+(defun render-generate ()
+ (render
+ (write-centered "Generating world, please wait..."
+ *screen-center-x* *screen-center-y*)))
+
+
+(defun draw-terrain ()
+ (iterate
+ (repeat *screen-width*)
+ (for sx :from 0)
+ (for wx :from *view-x*)
+ (iterate
+ (repeat *screen-height*)
+ (for sy :from 0)
+ (for wy :from *view-y*)
+ (for (values terrain-char terrain-color) = (terrain-char wx wy))
+ (for entity = (car (member-if (lambda (e) (typep e 'visible))
+ (coords-lookup wx wy))))
+ (if entity
+ (with-color (visible/color entity)
+ (charms:write-string-at-point
+ charms:*standard-window*
+ (visible/glyph entity)
+ sx sy))
+ (with-color terrain-color
+ (charms:write-char-at-point
+ charms:*standard-window*
+ terrain-char
+ sx sy))))))
+
+(defun draw-ui ()
+ (write-right
+ (list
+ (format nil "[~D, ~D]" *view-x* *view-y*)
+ (format nil "[~D, ~D]" *cursor-x* *cursor-y*)
+ (format nil "~D entities" (hash-table-count *entity-index*)))
+ (1- *screen-width*)
+ 0)
+ (write-left
+ (iterate
+ (for entity :in (multiple-value-call #'coords-lookup
+ (screen-to-world *cursor-x* *cursor-y*)))
+ (when (typep entity 'flavor)
+ (collect (flavor/text entity))))
+ 0 0))
+
+
+(defun render-map ()
+ (manage-screen)
+ (draw-terrain)
+ (draw-ui)
+ (charms:move-cursor charms:*standard-window* *cursor-x* *cursor-y*))
+
+
+(defun press-any-key ()
+ (charms:disable-non-blocking-mode charms:*standard-window*)
+ (charms:get-char charms:*standard-window*))
+
+(defun handle-input-map ()
+ (iterate
+ (for key = (charms:get-char charms:*standard-window* :ignore-error t))
+ (while key)
+ (case key
+ ((#\Q) (return :quit))
+ ((#\R) (return :regen))
+ ((#\?) (return :help))
+
+ ((#\h) (move-view -5 0))
+ ((#\j) (move-view 0 5))
+ ((#\k) (move-view 0 -5))
+ ((#\l) (move-view 5 0))
+ ((#\y) (move-view -5 -5))
+ ((#\u) (move-view 5 -5))
+ ((#\b) (move-view -5 5))
+ ((#\n) (move-view 5 5))
+
+ ((#\H) (move-view -30 0))
+ ((#\J) (move-view 0 30))
+ ((#\K) (move-view 0 -30))
+ ((#\L) (move-view 30 0))
+ ((#\Y) (move-view -30 -30))
+ ((#\U) (move-view 30 -30))
+ ((#\B) (move-view -30 30))
+ ((#\N) (move-view 30 30))
+
+ ((#\w) (move-cursor 0 -1))
+ ((#\a) (move-cursor -1 0))
+ ((#\s) (move-cursor 0 1))
+ ((#\d) (move-cursor 1 0))
+ ((#\W) (move-cursor 0 -10))
+ ((#\A) (move-cursor -10 0))
+ ((#\S) (move-cursor 0 10))
+ ((#\D) (move-cursor 10 0))
+
+ (t (push key *debug*) t))))
+
+
+(defun tick-world ()
+ (run-system 'grow-fruit))
+
+
+(defun state-title ()
+ (render-title)
+ (press-any-key)
+ (state-intro))
+
+(defun state-intro ()
+ (render-intro)
+ (press-any-key)
+ (state-generate))
+
+(defun state-generate ()
+ (render-generate)
+ (clear-entities)
+ (setf *heightmap* (diamond-square (allocate-heightmap))
+ *view-x* 0
+ *view-y* 0
+ *cursor-x* 0
+ *cursor-y* 0)
+ (grow-trees)
+ (grow-algae)
+ (state-map))
+
+(defun state-map ()
+ (charms:enable-non-blocking-mode charms:*standard-window*)
+ (case (handle-input-map)
+ ((:quit) (state-quit))
+ ((:regen) (state-generate))
+ ((:help) (state-help))
+ (t
+ (tick-world)
+ (render-map)
+ (sleep 0.02)
+ (state-map))))
+
+
+(defun state-help ()
+ (render-help)
+ (press-any-key)
+ (state-map))
+
+(defun state-quit ()
+ 'goodbye)
+
+
+;;;; Run
+(defun run ()
+ (setf *running* t)
+ (charms:with-curses ()
+ (charms:disable-echoing)
+ (charms:enable-raw-input :interpret-control-characters t)
+ (charms:enable-extra-keys charms:*standard-window*)
+ (charms/ll:start-color)
+ (init-colors)
+ (state-title)))
+
+(defun main ()
+ (handler-case
+ (progn
+ (run)
+ (format t "Goodbye.~%"))
+ (t (e)
+ (declare (ignore e))
+ (format t "Something went wrong, sorry.~%"))))
+
+
+;;;; Scratch
+; (run)
+; (start-profiling)
+; (stop-profiling)
--- a/src/main.lisp Fri Aug 05 16:15:43 2016 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,811 +0,0 @@
-(in-package #:silt)
-(require :sb-sprof)
-
-;;;; Data
-(defparameter *running* nil)
-(defparameter *running* t)
-(defparameter *debug* nil)
-
-(defparameter *screen-width* 1)
-(defparameter *screen-height* 1)
-(defparameter *screen-center-x* 1)
-(defparameter *screen-center-y* 1)
-
-(define-constant +world-exponent+ 9)
-(define-constant +world-size+ (expt 2 +world-exponent+))
-
-(defparameter *view-x* 0)
-(defparameter *view-y* 0)
-
-(defparameter *cursor-x* 0)
-(defparameter *cursor-y* 0)
-
-(deftype world-coordinate ()
- `(integer 0 ,(1- +world-size+)))
-
-(deftype world-array ()
- `(simple-array single-float (,+world-size+ ,+world-size+)))
-
-(defun allocate-heightmap ()
- (make-array (list +world-size+ +world-size+)
- :element-type 'single-float
- :initial-element 0.0
- :adjustable nil))
-
-(defvar *heightmap* (allocate-heightmap))
-
-(declaim (type world-array *heightmap*))
-
-
-;;;; Colors
-(define-constant +color-white+ 0)
-(define-constant +color-blue+ 1)
-(define-constant +color-yellow+ 2)
-(define-constant +color-cyan+ 3)
-(define-constant +color-snow+ 4)
-(define-constant +color-green+ 5)
-(define-constant +color-pink+ 6)
-
-(defun init-colors ()
- (charms/ll:init-pair +color-white+ charms/ll:COLOR_WHITE charms/ll:COLOR_BLACK)
- (charms/ll:init-pair +color-blue+ charms/ll:COLOR_BLUE charms/ll:COLOR_BLACK)
- (charms/ll:init-pair +color-yellow+ charms/ll:COLOR_YELLOW charms/ll:COLOR_BLACK)
- (charms/ll:init-pair +color-cyan+ charms/ll:COLOR_CYAN charms/ll:COLOR_BLACK)
- (charms/ll:init-pair +color-snow+ charms/ll:COLOR_BLACK charms/ll:COLOR_WHITE)
- (charms/ll:init-pair +color-green+ charms/ll:COLOR_GREEN charms/ll:COLOR_BLACK)
- (charms/ll:init-pair +color-pink+ charms/ll:COLOR_MAGENTA charms/ll:COLOR_BLACK))
-
-(defmacro with-color (color &body body)
- (once-only (color)
- `(unwind-protect
- (prog2
- (charms/ll:attron (charms/ll:color-pair ,color))
- (progn ,@body))
- (charms/ll:attroff (charms/ll:color-pair ,color)))))
-
-
-;;;; Utils
-(defun manage-screen ()
- (multiple-value-bind (w h)
- (charms:window-dimensions charms:*standard-window*)
- (setf *screen-width* (1- w) *screen-height* (1- h)
- *screen-center-x* (floor w 2)
- *screen-center-y* (floor h 2))))
-
-(defmacro render (&body body)
- `(prog2
- (progn
- (manage-screen)
- (charms:clear-window charms:*standard-window*))
- (progn ,@body)
- (charms:refresh-window charms:*standard-window*)))
-
-(defun clamp-w (x)
- (clamp 0 (1- *screen-width*) x))
-
-(defun clamp-h (y)
- (clamp 0 (1- *screen-height*) y))
-
-
-(defun write-string-at (string x y)
- (charms:write-string-at-point
- charms:*standard-window*
- string
- (clamp-w x)
- (clamp-h y)))
-
-
-(defun write-centered (text x y)
- (etypecase text
- (string (write-centered (list text) x y))
- (list (iterate
- (for string :in text)
- (for tx = (- x (floor (length string) 2)))
- (for ty :from y)
- (write-string-at string tx ty)))))
-
-(defun write-left (text x y)
- (etypecase text
- (string (write-left (list text) x y))
- (list (iterate
- (for string :in text)
- (for tx = x)
- (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)
- (+ value (- (random (* 2.0 spread))
- spread)))
-
-(defun average (&rest values)
- (/ (apply #'+ values) (length values)))
-
-
-
-
-(defun hm-size (heightmap)
- (first (array-dimensions heightmap)))
-
-(defun hm-ref (heightmap x y)
- (let ((last (hm-size heightmap)))
- (aref heightmap
- (cond
- ((< -1 x last) x)
- ((= x last) 0)
- (t (mod x last)))
- (cond
- ((< -1 y last) y)
- ((= y last) 0)
- (t (mod y last))))))
-
-
-(defun normalize-heightmap (heightmap)
- (iterate
- (for i :from 0 :below (array-total-size heightmap))
- (for v = (row-major-aref heightmap i))
- (maximize v :into max)
- (minimize v :into min)
- (finally
- (iterate
- (with span = (- max min))
- (for i :from 0 :below (array-total-size heightmap))
- (for v = (row-major-aref heightmap i))
- (setf (row-major-aref heightmap i)
- (/ (- v min) span))))))
-
-
-(defun ds-init (heightmap)
- (setf (aref heightmap 0 0) 0.5))
-
-
-(defun ds-square (heightmap x y radius spread)
- (setf (aref heightmap x y)
- (jitter (average (hm-ref heightmap (- x radius) (- y radius))
- (hm-ref heightmap (- x radius) (+ y radius))
- (hm-ref heightmap (+ x radius) (- y radius))
- (hm-ref heightmap (+ x radius) (+ y radius)))
- spread)))
-
-(defun ds-diamond (heightmap x y radius spread)
- (setf (aref heightmap x y)
- (jitter (average (hm-ref heightmap (- x radius) y)
- (hm-ref heightmap (+ x radius) y)
- (hm-ref heightmap x (- y radius))
- (hm-ref heightmap x (+ y radius)))
- spread)))
-
-
-(defun ds-squares (heightmap radius spread)
- (iterate
- (for x :from radius :below (hm-size heightmap) :by (* 2 radius))
- (iterate
- (for y :from radius :below (hm-size heightmap) :by (* 2 radius))
- (ds-square heightmap x y radius spread))))
-
-(defun ds-diamonds (heightmap radius spread)
- (iterate
- (for i :from 0)
- (for y :from 0 :below (hm-size heightmap) :by radius)
- (for shift = (if (evenp i) radius 0))
- (iterate
- (for x :from shift :below (hm-size heightmap) :by (* 2 radius))
- (ds-diamond heightmap x y radius spread))))
-
-
-(defun diamond-square (heightmap)
- (ds-init heightmap)
- (let ((spread 0.7)
- (spread-reduction 0.6))
- (recursively ((radius (floor (hm-size heightmap) 2))
- (spread spread))
- (when (>= radius 1)
- (ds-squares heightmap radius spread)
- (ds-diamonds heightmap radius spread)
- (recur (/ radius 2)
- (* spread spread-reduction)))))
- (normalize-heightmap heightmap)
- heightmap)
-
-
-;;;; Miscellaneous
-(declaim (inline wrap)
- (ftype (function (fixnum) world-coordinate) wrap)
- (ftype (function (fixnum fixnum)) terrain-type terrain-char))
-
-(defun wrap (coord)
- (mod coord +world-size+))
-
-(defun move-view (dx dy)
- (setf *view-x* (wrap (+ *view-x* dx))
- *view-y* (wrap (+ *view-y* dy))))
-
-(defun move-cursor (dx dy)
- (setf *cursor-x* (clamp-w (+ *cursor-x* dx))
- *cursor-y* (clamp-h (+ *cursor-y* dy))))
-
-
-(defun terrain-type (x y)
- (let ((h (aref *heightmap* (wrap x) (wrap y))))
- (cond ((< h 0.23) :deep-water)
- ((< h 0.3) :shallow-water)
- ((< h 0.34) :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 (wrap (- wx *view-x*))
- (wrap (- wy *view-y*))))
-
-(defun screen-to-world (sx sy)
- "Convert screen-space coordinates to world-space."
- (values (wrap (+ sx *view-x*))
- (wrap (+ sy *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*)))
-
-
-;;;; 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}}
-;;;
-;;; Entities are indexed by system too:
-;;;
-;;; {system-symbol ->
-;;; ({id -> entity} ; arg1
-;;; {id -> entity}) ; arg2
-;;; }
-;;;
-;;; Systems are stored as:
-;;;
-;;; {system-symbol -> (cons system-function type-specifier-list)}
-;;;
-;;; TODO: Figure out the distinct problem.
-
-(defvar *entity-id-counter* 0)
-(defvar *entity-index* (make-hash-table))
-(defvar *component-index* (make-hash-table))
-(defvar *systems* (make-hash-table))
-(defvar *system-index* (make-hash-table))
-
-
-(defun clear-entities ()
- (mapc #'destroy-entity (hash-table-values *entity-index*)))
-
-(defun get-entity (id)
- (gethash id *entity-index*))
-
-
-(defun index-entity (e)
- (setf (gethash (entity-id e) *entity-index*) e))
-
-(defun satisfies-system-type-specifier-p (entity specifier)
- (every (lambda (component) (typep entity component))
- specifier))
-
-(defun index-entity-systems (e)
- (iterate
- (for (system (function . type-specifiers)) :in-hashtable *systems*)
- (iterate
- (for argument-index :in (gethash system *system-index*))
- (for specifier :in type-specifiers)
- (when (satisfies-system-type-specifier-p e specifier)
- (setf (gethash (entity-id e) argument-index) e)))))
-
-
-(defclass entity ()
- ((id :reader entity-id :initform (incf *entity-id-counter*))))
-
-(defmethod print-object ((e entity) stream)
- (print-unreadable-object (e stream :type t :identity nil)
- (format stream "~D" (entity-id e))))
-
-(defmethod initialize-instance :after ((e entity) &key)
- (index-entity e)
- (index-entity-systems e))
-
-
-(defgeneric entity-created (entity)
- (:method ((entity entity)) nil))
-
-(defgeneric entity-destroyed (entity)
- (:method ((entity entity)) nil))
-
-
-(defun create-entity (class &rest initargs)
- (let ((entity (apply #'make-instance class initargs)))
- (entity-created entity)
- entity))
-
-(defun destroy-entity (entity)
- (let ((id (entity-id entity)))
- (remhash id *entity-index*)
- (iterate
- (for (nil index) :in-hashtable *component-index*)
- (remhash id index))
- (iterate
- (for (nil argument-indexes) :in-hashtable *system-index*)
- (iterate (for index :in argument-indexes)
- (remhash id index))))
- (entity-destroyed entity)
- nil)
-
-
-(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)
- `(progn
- (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 *systems*)
- (cons #',name ',(mapcar #'cdr arglist))
- (gethash ',name *system-index*)
- (list ,@(iterate (repeat (length arglist))
- (collect `(make-hash-table)))))
- ',name))
-
-(defun run-system (system)
- (destructuring-bind (system-function . type-specifiers)
- (gethash system *systems*)
- (declare (ignore type-specifiers))
- (apply #'map-product system-function
- (mapcar #'hash-table-values (gethash system *system-index*)))
- (values)))
-
-
-;;;; Coordinates
-(define-component coords x y)
-
-
-(defparameter *coords-contents* (make-hash-table))
-
-
-(defun coordinate-key (x y)
- (array-row-major-index *heightmap* (wrap x) (wrap y)))
-
-(defun coordinate-key-for-entity (e)
- (coordinate-key (coords/x e) (coords/y e)))
-
-
-(defun coords-insert-entity (e)
- (push e (gethash (coordinate-key-for-entity e) *coords-contents*)))
-
-(defun coords-remove-entity (e)
- (let ((k (coordinate-key-for-entity e)))
- (when (null (zap% (gethash k *coords-contents*)
- #'delete e %))
- (remhash k *coords-contents*))))
-
-(defun coords-move-entity (e new-x new-y)
- (coords-remove-entity e)
- (setf (coords/x e) new-x
- (coords/y e) new-y)
- (coords-insert-entity e))
-
-(defun coords-lookup (x y)
- (gethash (coordinate-key x y) *coords-contents*))
-
-
-(defmethod entity-created :after ((entity coords))
- (coords-insert-entity entity))
-
-(defmethod entity-destroyed :after ((entity coords))
- (coords-remove-entity entity))
-
-
-;;;; Flavor Text
-(define-component flavor text)
-
-;;; Components
-(define-component visible
- (glyph :type string)
- color)
-
-(define-component edible
- energy)
-
-(define-component fruiting
- chance)
-
-
-;;; Entities
-(define-entity fruit (coords visible edible flavor))
-(define-entity tree (coords visible fruiting flavor))
-(define-entity algae (coords visible edible))
-
-(defun make-tree (x y)
- (create-entity 'tree
- :coords/x x
- :coords/y y
- :visible/glyph "T"
- :visible/color +color-green+
- :fruiting/chance 0.0001
- :flavor/text "A tree sways gently in the wind."))
-
-(defun make-fruit (x y)
- (create-entity 'fruit
- :coords/x x
- :coords/y y
- :visible/glyph "ó"
- :visible/color +color-pink+
- :edible/energy (random-around 10 3)
- :flavor/text "A ripe piece of fruit has fallen to the ground."))
-
-(defun make-algae (x y)
- (create-entity 'algae
- :coords/x x
- :coords/y y
- :visible/glyph "`"
- :visible/color +color-green+))
-
-
-;;; Systems
-
-(define-system grow-fruit ((entity fruiting coords))
- (when (< (random 1.0) (fruiting/chance entity))
- (make-fruit (wrap (random-around (coords/x entity) 2))
- (wrap (random-around (coords/y entity) 2)))))
-
-
-;;;; 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)))))
-
-
-
-;;;; Profiling
-(sb-sprof::profile-call-counts "SILT")
-(defvar *profiling* nil)
-
-(defun dump-profile ()
- (with-open-file (*standard-output* "silt.prof"
- :direction :output
- :if-exists :supersede)
- (sb-sprof:report :type :graph
- :sort-by :cumulative-samples
- :sort-order :ascending)
- (sb-sprof:report :type :flat
- :min-percent 0.5)))
-
-(defun start-profiling ()
- (sb-sprof::reset)
- (sb-sprof::start-profiling :max-samples 50000
- :mode :cpu
- :sample-interval 0.005
- :threads :all)
- (setf *profiling* t))
-
-(defun stop-profiling ()
- (setf *profiling* nil)
- (sb-sprof::stop-profiling)
- (dump-profile))
-
-
-;;;; Game State Machine
-(defun render-title ()
- (render
- (write-centered '("S I L T"
- ""
- "Press any key to start...")
- *screen-center-x*
- (1- *screen-center-y*))))
-
-(defun render-intro ()
- (render
- (write-left '("Welcome to Silt."
- ""
- "You are the god of a toroidal world."
- ""
- "CONTROLS"
- " hjklyubn - move your view"
- " HJKLYUBN - move your view faster"
- ""
- " wasd - move your cursor"
- " WASD - move your cursor faster"
- ""
- " Q - quit"
- " R - regenerate the world"
- ""
- " ? - help"
- ""
- "Press any key to begin."
- )
- 1 1)))
-
-(defun render-help ()
- (render
- (write-left '("CONTROLS"
- " hjklyubn - move your view"
- " HJKLYUBN - move your view faster"
- ""
- " wasd - move your cursor"
- " WASD - move your cursor faster"
- ""
- " Q - quit"
- " R - regenerate the world"
- ""
- " ? - help"
- ""
- "Press any key to continue."
- )
- 1 1)))
-
-(defun render-generate ()
- (render
- (write-centered "Generating world, please wait..."
- *screen-center-x* *screen-center-y*)))
-
-
-(defun draw-terrain ()
- (iterate
- (repeat *screen-width*)
- (for sx :from 0)
- (for wx :from *view-x*)
- (iterate
- (repeat *screen-height*)
- (for sy :from 0)
- (for wy :from *view-y*)
- (for (values terrain-char terrain-color) = (terrain-char wx wy))
- (for entity = (car (member-if (lambda (e) (typep e 'visible))
- (coords-lookup wx wy))))
- (if entity
- (with-color (visible/color entity)
- (charms:write-string-at-point
- charms:*standard-window*
- (visible/glyph entity)
- sx sy))
- (with-color terrain-color
- (charms:write-char-at-point
- charms:*standard-window*
- terrain-char
- sx sy))))))
-
-(defun draw-ui ()
- (write-right
- (list
- (format nil "[~D, ~D]" *view-x* *view-y*)
- (format nil "[~D, ~D]" *cursor-x* *cursor-y*)
- (format nil "~D entities" (hash-table-count *entity-index*)))
- (1- *screen-width*)
- 0)
- (write-left
- (iterate
- (for entity :in (multiple-value-call #'coords-lookup
- (screen-to-world *cursor-x* *cursor-y*)))
- (when (typep entity 'flavor)
- (collect (flavor/text entity))))
- 0 0))
-
-
-(defun render-map ()
- (manage-screen)
- (draw-terrain)
- (draw-ui)
- (charms:move-cursor charms:*standard-window* *cursor-x* *cursor-y*))
-
-
-(defun press-any-key ()
- (charms:disable-non-blocking-mode charms:*standard-window*)
- (charms:get-char charms:*standard-window*))
-
-(defun handle-input-map ()
- (iterate
- (for key = (charms:get-char charms:*standard-window* :ignore-error t))
- (while key)
- (case key
- ((#\Q) (return :quit))
- ((#\R) (return :regen))
- ((#\?) (return :help))
-
- ((#\h) (move-view -5 0))
- ((#\j) (move-view 0 5))
- ((#\k) (move-view 0 -5))
- ((#\l) (move-view 5 0))
- ((#\y) (move-view -5 -5))
- ((#\u) (move-view 5 -5))
- ((#\b) (move-view -5 5))
- ((#\n) (move-view 5 5))
-
- ((#\H) (move-view -30 0))
- ((#\J) (move-view 0 30))
- ((#\K) (move-view 0 -30))
- ((#\L) (move-view 30 0))
- ((#\Y) (move-view -30 -30))
- ((#\U) (move-view 30 -30))
- ((#\B) (move-view -30 30))
- ((#\N) (move-view 30 30))
-
- ((#\w) (move-cursor 0 -1))
- ((#\a) (move-cursor -1 0))
- ((#\s) (move-cursor 0 1))
- ((#\d) (move-cursor 1 0))
- ((#\W) (move-cursor 0 -10))
- ((#\A) (move-cursor -10 0))
- ((#\S) (move-cursor 0 10))
- ((#\D) (move-cursor 10 0))
-
- (t (push key *debug*) t))))
-
-
-(defun tick-world ()
- (run-system 'grow-fruit))
-
-
-(defun state-title ()
- (render-title)
- (press-any-key)
- (state-intro))
-
-(defun state-intro ()
- (render-intro)
- (press-any-key)
- (state-generate))
-
-(defun state-generate ()
- (render-generate)
- (clear-entities)
- (setf *heightmap* (diamond-square (allocate-heightmap))
- *view-x* 0
- *view-y* 0
- *cursor-x* 0
- *cursor-y* 0)
- (grow-trees)
- (grow-algae)
- (state-map))
-
-(defun state-map ()
- (charms:enable-non-blocking-mode charms:*standard-window*)
- (case (handle-input-map)
- ((:quit) (state-quit))
- ((:regen) (state-generate))
- ((:help) (state-help))
- (t
- (tick-world)
- (render-map)
- (sleep 0.02)
- (state-map))))
-
-
-(defun state-help ()
- (render-help)
- (press-any-key)
- (state-map))
-
-(defun state-quit ()
- 'goodbye)
-
-
-;;;; Run
-(defun run ()
- (setf *running* t)
- (charms:with-curses ()
- (charms:disable-echoing)
- (charms:enable-raw-input :interpret-control-characters t)
- (charms:enable-extra-keys charms:*standard-window*)
- (charms/ll:start-color)
- (init-colors)
- (state-title)))
-
-(defun main ()
- (handler-case
- (progn
- (run)
- (format t "Goodbye.~%"))
- (t (e)
- (declare (ignore e))
- (format t "Something went wrong, sorry.~%"))))
-
-
-;;;; Scratch
-; (run)
-; (start-profiling)
-; (stop-profiling)
--- a/src/utils.lisp Fri Aug 05 16:15:43 2016 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,234 +0,0 @@
-(in-package #:silt.utils)
-
-;;;; Miscellaneous
-(defmacro zap% (place function &rest arguments &environment env)
- "Update `place` by applying `function` to its current value and `arguments`.
-
- `arguments` should contain the symbol `%`, which is treated as a placeholder
- where the current value of the place will be substituted into the function
- call.
-
- For example:
-
- (zap% foo #'- % 10) => (setf foo (- foo 10)
- (zap% foo #'- 10 %) => (setf foo (- 10 foo)
-
- "
- ;; original idea/name from http://malisper.me/2015/09/29/zap/
- (assert (find '% arguments) ()
- "Placeholder % not included in zap macro form.")
- (multiple-value-bind (temps exprs stores store-expr access-expr)
- (get-setf-expansion place env)
- `(let* (,@(mapcar #'list temps exprs)
- (,(car stores)
- (funcall ,function
- ,@(substitute access-expr '% arguments))))
- ,store-expr)))
-
-(defmacro recursively (bindings &body body)
- "Execute body recursively, like Clojure's `loop`/`recur`.
-
- `bindings` should contain a list of symbols and (optional) default values.
-
- In `body`, `recur` will be bound to the function for recurring.
-
- Example:
-
- (defun length (some-list)
- (recursively ((list some-list) (n 0))
- (if (null list)
- n
- (recur (cdr list) (1+ n)))))
-
- "
- (flet ((extract-var (binding)
- (if (atom binding) binding (first binding)))
- (extract-val (binding)
- (if (atom binding) nil (second binding))))
- `(labels ((recur ,(mapcar #'extract-var bindings)
- ,@body))
- (recur ,@(mapcar #'extract-val bindings)))))
-
-(defmacro dis (arglist &body body)
- "Disassemble the code generated for a `lambda*` with `arglist` and `body`.
-
- It will also spew compiler notes so you can see why the garbage box isn't
- doing what you think it should be doing.
-
- "
- `(->> '(lambda ,arglist
- (declare (optimize speed))
- ,@body)
- (compile nil)
- #+sbcl sb-disassem:disassemble-code-component
- #-sbcl disassemble))
-
-(defmacro spit (filename &body body)
- `(with-open-file (*standard-output* ,filename
- :direction :output
- :if-exists :supersede)
- ,@body))
-
-(defun symbolize (&rest args)
- (intern (format nil "~{~A~}" args)))
-
-
-;;;; Maths
-(defun d (n sides &optional (plus 0))
- "Roll some dice.
-
- (d 1 4) -> roll 1d4
- (d 2 8) -> roll 2d8
- (d 1 10 -1) -> roll 1d10-1
-
- "
- (+ (iterate (repeat n)
- (sum (1+ (random sides))))
- plus))
-
-(defun clamp (from to n)
- (let ((max (max from to))
- (min (min from to)))
- (cond
- ((> n max) max)
- ((< n min) min)
- (t n))))
-
-(defun random-range (min max)
- (+ min (random (- max min))))
-
-(defun random-around (val range)
- (random-range (- val range)
- (+ val range)))
-
-
-;;;; dlambda
-(defmacro dlambda (&rest clauses)
- (with-gensyms (message arguments)
- (flet ((parse-clause (clause)
- (destructuring-bind (key arglist &rest body)
- clause
- `(,key (apply (lambda ,arglist ,@body) ,arguments)))))
- `(lambda (,message &rest ,arguments)
- (ecase ,message
- ,@(mapcar #'parse-clause clauses))))))
-
-
-;;;; Sets
-;;; Janky implementation of basic sets.
-(defclass hash-set ()
- ((data :initarg :data)))
-
-
-(defun make-set (&key (test #'eql) (initial-data nil))
- (let ((set (make-instance 'hash-set
- :data (make-hash-table :test test))))
- (mapcar (curry #'set-add set) initial-data)
- set))
-
-
-(defun set-contains-p (set value)
- (nth-value 1 (gethash value (slot-value set 'data))))
-
-(defun set-empty-p (set)
- (zerop (hash-table-count (slot-value set 'data))))
-
-(defun set-add (set value)
- (setf (gethash value (slot-value set 'data)) t)
- value)
-
-(defun set-add-all (set seq)
- (map nil (curry #'set-add set) seq))
-
-(defun set-remove (set value)
- (remhash value (slot-value set 'data))
- value)
-
-(defun set-remove-all (set seq)
- (map nil (curry #'set-remove set) seq))
-
-(defun set-clear (set)
- (clrhash (slot-value set 'data))
- set)
-
-(defun set-random (set)
- (if (set-empty-p set)
- (values nil nil)
- (loop :with data = (slot-value set 'data)
- :with target = (random (hash-table-count data))
- :for i :from 0
- :for k :being :the :hash-keys :of data
- :when (= i target)
- :do (return (values k t)))))
-
-(defun set-pop (set)
- (multiple-value-bind (val found) (set-random set)
- (if found
- (progn
- (set-remove set val)
- (values val t))
- (values nil nil))))
-
-
-(defmethod print-object ((set hash-set) stream)
- (print-unreadable-object (set stream :type t)
- (format stream "~{~S~^ ~}"
- (iterate
- (for (key) :in-hashtable (slot-value set 'data))
- (collect key)))))
-
-
-;;;; Iterate
-(defmacro-clause (AVERAGING expr &optional INTO var)
- (with-gensyms (count)
- (let ((average (or var (gensym "average"))))
- `(progn
- (for ,average
- :first ,expr
- ;; continuously recompute the running average instead of keeping
- ;; a running total to avoid bignums when possible
- :then (/ (+ (* ,average ,count)
- ,expr)
- (1+ ,count)))
- (for ,count :from 1)
- ,(when (null var)
- ;; todo handle this better
- `(finally (return ,average)))))))
-
-(defmacro-clause (TIMING time-type &optional SINCE-START-INTO var PER-ITERATION-INTO per)
- (let ((timing-function (ecase time-type
- ((real-time) #'get-internal-real-time)
- ((run-time) #'get-internal-run-time)))
- (since (or var (gensym))))
- (with-gensyms (start-time current-time previous-time)
- `(progn
- (with ,start-time = (funcall ,timing-function))
- (for ,current-time = (funcall ,timing-function))
- (for ,previous-time :previous ,current-time :initially ,start-time)
- (for ,since = (- ,current-time ,start-time))
- ,(when per
- `(for ,per = (- ,current-time ,previous-time)))
- ,(when (and (null var) (null per))
- `(finally (return ,since)))))))
-
-(defmacro-driver (FOR var IN-WHATEVER seq)
- "Iterate over items in the given sequence.
-
- Unlike iterate's own `in-sequence` this won't use the horrifically inefficient
- `elt`/`length` functions on a list.
-
- "
- (let ((kwd (if generate 'generate 'for)))
- (with-gensyms (is-list source i len)
- `(progn
- (with ,source = ,seq)
- (with ,is-list = (typep ,source 'list))
- (with ,len = (if ,is-list -1 (length ,source)))
- (for ,i :from 0)
- (,kwd ,var next (if ,is-list
- (if ,source
- (pop ,source)
- (terminate))
- (if (< ,i ,len)
- (elt ,source ,i)
- (terminate))))))))