# HG changeset patch # User Steve Losh # Date 1470672924 0 # Node ID ebc88989782fa6210873febb2a7fe440acccf373 # Parent 13cffbf1735345df5eca0bd8e1b2580e3bef1ccc Add direction weights and proper mutations diff -r 13cffbf17353 -r ebc88989782f silt.lisp --- a/silt.lisp Mon Aug 08 15:06:30 2016 +0000 +++ b/silt.lisp Mon Aug 08 16:15:24 2016 +0000 @@ -92,6 +92,26 @@ (mapcar #'cdr ticklist)) +;;;; Weightlists ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defstruct (weightlist (:constructor %make-weightlist)) + weights sums items total) + +(defun make-weightlist (items weights) + "Make a weightlist of the given items and weights." + (%make-weightlist + :items items + :weights weights + :sums (prefix-sums weights) + :total (apply #'+ weights))) + +(defun weightlist-random (weightlist) + (iterate + (with n = (random (weightlist-total weightlist))) + (for item :in (weightlist-items weightlist)) + (for weight :in (weightlist-sums weightlist)) + (finding item :such-that (< n weight)))) + + ;;;; Utils ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun manage-screen () (multiple-value-bind (w h) @@ -749,7 +769,8 @@ ;;; Fauna (define-entity creature (coords visible sentient flavor metabolizing aging inspectable) - (name :accessor creature-name :initarg :name)) + (name :accessor creature-name :initarg :name) + (directions :accessor creature-directions :initarg :directions)) (define-entity corpse (coords visible flavor decomposing)) @@ -758,37 +779,77 @@ (defparameter *directions* (iterate dirs (for dx :from -1 :to 1) (iterate (for dy :from -1 :to 1) - (in dirs (collect (cons dx dy) :result-type 'vector))))) + (in dirs (collect (cons dx dy)))))) + +(defparameter *default-creature-directions* + (make-weightlist *directions* + (iterate (repeat (length *directions*)) + (collect 10)))) + +(defparameter *creature-colors* + (vector +color-white-black+ + +color-blue-black+ + +color-cyan-black+ + +color-yellow-black+ + +color-green-black+ + +color-pink-black+)) + +(defparameter *creature-glyphs* + (vector "@" "$" "?" "!" "&" "+")) + +(defun creature-mutate-glyph (c) + (setf (visible/glyph c) (random-elt *creature-glyphs*))) + +(defun creature-mutate-color (c) + (setf (visible/color c) (random-elt *creature-colors*))) + +(defun creature-mutate-directions (c) + (let ((old (creature-directions c))) + (setf (creature-directions c) + (make-weightlist (weightlist-items old) + (mapcar (lambda (w) + (max 0 (random-around w 2))) + (weightlist-weights old)))))) + +(defun creature-mutate-appearance (c) + (if (randomp) + (creature-mutate-color c) + (creature-mutate-glyph c))) (defun creature-mutate (c) (let ((v (random 1.0))) - (declare (ignore v)) (cond - (t (setf (visible/glyph c) - (random-elt #("@" "$" "?" "!" "&" "+"))))))) + ((< v 0.90) (creature-mutate-directions c)) + ((< v 0.99) (creature-mutate-color c)) + ((< v 1.00) (creature-mutate-glyph c))))) + (defun creature-should-reproduce-p (c) (and (> (metabolizing/energy c) 1000) (< (random 1.0) 0.01))) (defun creature-should-mutate-p () - (< (random 1.0) 0.01)) + (< (random 1.0) 0.1)) (defun creature-reproduce (parent) - (let ((energy (floor (metabolizing/energy parent) 2)) - (child (make-creature (coords/x parent) (coords/y parent)))) - (setf (metabolizing/energy parent) energy - (metabolizing/energy child) energy) + (let* ((energy (floor (metabolizing/energy parent) 2)) + (child (make-creature (coords/x parent) (coords/y parent) + :color (visible/color parent) + :glyph (visible/glyph parent) + :energy energy + :directions (creature-directions parent)))) + (setf (metabolizing/energy parent) energy) (when (creature-should-mutate-p) (creature-mutate child)) (log-message "~A begets ~A." (creature-name parent) (creature-name child)))) + (defun creature-move (c) (let ((x (coords/x c)) (y (coords/y c))) (destructuring-bind (dx . dy) - (random-elt *directions*) + (weightlist-random (creature-directions c)) (coords-move-entity c (+ x dx) (+ y dy))))) (defun creature-eat (c food) @@ -804,28 +865,33 @@ (t (creature-move c))))) -(defun make-creature (x y) +(defun make-creature (x y &key + (directions *default-creature-directions*) + (color +color-white-black+) + (glyph "@") + (energy 2000)) (let ((name (random-name))) (create-entity 'creature :name name + :directions directions :coords/x x :coords/y y - :visible/color +color-white-black+ - :visible/glyph "@" - :metabolizing/energy 2000 + :visible/color color + :visible/glyph glyph + :metabolizing/energy energy :metabolizing/insulation 1 :sentient/function 'creature-act - :inspectable/slots '(metabolizing/energy aging/birthtick aging/age) + :inspectable/slots '(name directions metabolizing/energy aging/birthtick aging/age) :flavor/text (list (format nil "A creature named ~:(~A~) is here." name) "It likes food.")))) -(defun make-corpse (x y name) +(defun make-corpse (x y color name) (create-entity 'corpse :coords/x x :coords/y y - :visible/color +color-white-black+ + :visible/color color :visible/glyph "%" :decomposing/rate 0.001 :flavor/text (list (format nil "The corpse of ~:(~A~) lies here." name)))) @@ -837,6 +903,7 @@ (aging/age c)) (make-corpse (coords/x c) (coords/y c) + (visible/color c) (creature-name c))) @@ -880,7 +947,7 @@ (iterate (for creature :in (remove-if-not #'creature? (nearby f))) (unless (member creature (ticklist-contents recent)) - (creature-mutate creature) + (creature-mutate-appearance creature) (ticklist-push recent creature 1000) (log-message "~A drinks from the fountain and... changes." (creature-name creature)))))) @@ -1081,8 +1148,9 @@ (mapcar (compose #'length #'symbol-name) slots))) (for slot :in slots) - (collect (format nil "~vA ~A" - width slot (slot-value entity slot))))) + (collect (let ((*print-pretty* nil)) + (format nil "~vA ~A" + width slot (slot-value entity slot)))))) :into text)) (collecting "" :into text))