;;;; creatures.lisp ;;; Time-stamp: <96/08/24 20:43:26 john> ;;; Created 95 Dec 16 ;;; This file has lots of little creatures in it. ;; (make-package :creatures) ;; (in-package :creatures) ;;;; To do: ;;; better world definition system (proclaim '(special *all-languages-by-name* *all-taxa-by-name* *all-realms-by-name* *dead-realm* *realm-directory* *print-creature-genomes* *print-creature-biographies* *creature-verbose* *reporting-level*)) ;;;; structures (defstruct realm "This is a region of the ecosystem." ;; for convenience and reference -- unique please name ;; list of creatures in this realm creatures ;; taxa that have appeared in this realm taxa ;; outgoing message queue for broadcast messages from any creatures in ;; this realm and audible to any creatures in the same realm shouts ;; table of non-creatures in this realm inorganics ;; any general changes to the realm to do on each step step-inorganics ;; larger realm of which this is part super-realm ;; parts of this realm sub-realms ;; limits of the values for each creature's x, y and z values, as a vector ;; [ x X y Y z Z ] boundaries ) (defmacro with-boundaries (bounds &body body) "With BOUNDS for x-min .. z-max, evaluate BODY." `(let* ((bs ,bounds) (x-min (aref bs 0)) (x-max (aref bs 1)) (y-min (aref bs 2)) (y-max (aref bs 3)) (z-min (aref bs 4)) (z-max (aref bs 5))) ,@body)) (defstruct (language (:print-function print-language)) "The possible contents for a genome." ;; to say where definitions go name ;; hash table of cons of vectors of operator by result type, used in ;; creation of step codes for initial populations and for ;; type-strict crossover while breeding; the car is all operators ;; and the cdr is the terminal-only subset thereof genome-operators-by-type ;; hash table of operators available for current program, mapping ;; operator name to Lisp code implementing it operators ;; alimit on the depth of initial forms form-depth ;; types available for current program, mapping type name to Lisp ;; code implementing it type-evals ) (defstruct taxon "This is one taxon of creature. Taxa differ in what is possible in their genomes." ;; for convenience; the programmer can set the names of initially ;; existing taxa name ;; how many chromosomes (there is only one kind so this is not a ;; chromosome count in the natural biology sense) ploidy ;; what the loci are called -- allow the programmer to set these ;; for convenience -- if nil, made at random for each individual ;; when the initial population is created locus-keys ;; the type or types that may result from each step step-type ;; characteristics of operators for our genome language ;; what is in the state / memory of a new creature default-state ;; the amount of energy reserves a creature of this taxon has at birth initial-energy ;; the possible sexes, as a list sexes ;; many taxa may want to vary around some number, so make this a function litter-size ;; hashtable of various oddments that operators might use, such as ;; how much energy a creature uses by doing a particular action -- ;; accessed via get-parameter, and is looked for here if not found ;; specifically for the individual creature parameters ;; lisp function to apply to realm when this taxon first appears in that realm inorganics-setup ;; lisp routine to output PostScript to draw this creature, ;; within a unit square with 0 0 at the centre render-as-PostScript ;; string to include in header of PostScript pictures of realms containing ;; this taxon header-PostScript ) (defstruct (creature (:print-function print-creature)) "This is one creature. Creatures are implemented as state machines, and the entire state of the creature is in, or reachable from, this structure." ;; identify each organism uniquely name ;; what kind of creature -- this gives us language etc for evaluation taxon ;; sex -- reproductive systems are per-taxon and may optionally ;; have two distinct sexes, :male and :female. Breeding may take ;; place only between males and females of the same taxon, but if ;; sex is nil, any member of a taxon may breed with any other but ;; each of the pair will produce a litter of the specified ;; size. Either way, reproduction is asymmetric -- just like in real ;; biology, the father can contribute only part of the genome, ;; everything else is copied from the mother. sex ;; the current program, which is an array of conses of promoter and gene chromosomes ;; in evaluation, to implement polyploidy, we step right along each ;; chromosome in turn, trying promoters until one fires, and running the ;; associated gene chromosome-active-point chromosomes-active-index ;; result of latest evaluation fitness ;; trail of loci activated biography ;; how much energy reserves this creature has, as just a number -- some ;; taxa may want to do fancier things within their state, but ;; this is the basic "glycongen level" or equivalent, ticked down ;; automatically by the evaluator framework and loaded up again by ;; eating. Operators may bring it down specifically to represent ;; strenuous operations. energy ;; incoming message queue for messages sent specifically to this ;; individual ear ;; mark which things that have been shouted so far in this we have ;; heard so far -- shouts shouted before we were born are not heard latest-shout-heard ;; number of evaluation steps so far age ;; assorted things to remember -- simply a hash-table of variables state ;; local environment, of type realm realm ;; ancestors -- cons of two parents ;; we will keep the ancestry indefinitely; dead ancestors will hence ;; be retained in memory, but they won't be on the individuals list ;; of any realm and so will not be stepped ancestry ;; location in three dimensions, just like in analytical biology! x y z ;; facing direction dx dy dz ;; hashtable of various oddments that operators might use, such as ;; how much energy a creature uses by doing a particular action -- ;; accessed via get-parameter, and if not given here that will look ;; in the corresponding slot in the taxon parameters ) (defstruct operator ;; the name of the operator, by which it is keyed name ;; the language of which this operator is part -- after all there ;; could be several languages with operators of the same names, and ;; we must know which is which for doing type-strict crossover language ;; result type -- we must know this for type-strict crossover as well as ;; for the creation of creatures for initial populations result-type ;; list of argument types, again needed for crossover and seeding; ;; or if this operator is a terminal (e.g. a variable name) it is :terminal argument-types ;; whether to evaluate the arguments for it -- all-or-nothing is ;; fast-and-simple eval-args-please ;; a lisp symbol, which will be used as a key into a language to get ;; the Lisp code that implemnts it evaluator-name ) (defstruct locus ;; names the locus -- a number by default key ;; a boolean expression promoter ;; an expression of the appropriate step-type for its language action ) ;;;; global and default structures (defvar *creature-verbose* t "Whether to output various progress messages.") (defun reset () "Reset the globals" (setq *all-languages-by-name* (make-hash-table :test #'eq) *all-taxa-by-name* (make-hash-table :test #'eq) *all-realms-by-name* (make-hash-table :test #'eq) ;; *default-type-evaluators* nil )) (defun default-default-type-evaluator (expr individual) "The default default type evaluator (identity on value, throwing away context)." (declare (ignore individual)) expr) (defvar *default-type-evaluators* (let ((type-evals (make-hash-table :test #'eq))) (setf (gethash :default type-evals) 'default-default-type-evaluator) type-evals) "How to evaluate each type of expression.") (defvar *name* 0 "The counter for issuing names.") (defvar *all-realms-by-name* (make-hash-table :test #'eq) "Provides a namespace for realms.") (defvar *all-taxa-by-name* (make-hash-table :test #'eq) "Provides a namespace for taxa.") (defvar *all-languages-by-name* (make-hash-table :test #'eq) "Provides a namespace for languages.") ;;;; generally useful macros (defmacro lookup1 (name1 environment1) "Look NAME up in ENVIRONMENT." `(let ((env ,environment1)) (multiple-value-bind (result found) (gethash ,name1 env) (if found result (gethash :default env))))) (defmacro lookup (name environment) "Look NAME up in ENVIRONMENT." `(let ((result (lookup1 ,name ,environment))) ;; (format t "Lookup ~S in ~S ==> ~S~%" ,name ,environment result) ;; (format t "Lookup ~S ==> ~S~%" ,name result) result)) ;;;; general evaluator framework (defmacro beval (expr individual) "Evaluate EXPR for INDIVIDUAL." `(funcall (lookup (type-of ,expr) (language-type-evals (taxon-language (creature-taxon ,individual)))) ,expr ,individual)) (defmacro beval-with-debug (expr individual) "Evaluate EXPR for INDIVIDUAL." `(let* ((fn (lookup (type-of ,expr) (language-type-evals (taxon-language (creature-taxon ,individual)))))) (format t "beval got type-eval ~S~%" fn) (funcall fn ,expr ,individual))) ;;;; defining evaluator pieces to fit onto the framework (defmacro plain-name (name) "Return a name based on NAME that suits us for use a file or directory name." `(string-trim ":/" (if (stringp ,name) ,name (symbol-name ,name)))) (defmacro def-type-evaluator (type arglist &body body) "Define a default evaluator for TYPE taking ARGLIST for body BODY." ;; (format t "evaluator body is ~S~%" body) (let ((evaluator-name (intern (concatenate 'string "default-type-evaluator-for-" (plain-name type))))) ;; (when (stringp (car body)) (setq body (cdr body))) `(progn (compile ',evaluator-name '(lambda ,arglist (progn ,@body))) (setf (gethash ',type *default-type-evaluators*) ',evaluator-name)))) ;;;; standard pieces for evaluators (def-type-evaluator cons (form this-creature) "Evaluate FORM in context of THIS-CREATURE." (let* ((op (car form))) (unless (operator-p op) (setq op (lookup op (language-operators (taxon-language (creature-taxon this-creature)))))) (apply (operator-evaluator-name op) this-creature (if (operator-eval-args-please op) (loop for arg in (cdr form) collect (beval arg this-creature)) (cdr form))))) (def-type-evaluator symbol (form this-creature) "Evaluate SYMBOL in context of THIS-CREATURE." (lookup form (creature-state this-creature))) ;; (format t "Default type evaluators:~%") ;; (maphash #'(lambda (k v) (format t "~S: ~S~%" k v)) *default-type-evaluators*) ;;;; defining language pieces (defmacro find-language1 (language) "Find LANGUAGE; don't try to load it if not found." `(gethash ,language *all-languages-by-name*)) (defun install-operator (language name type arglist evaluated evaluator-name) "Do all the book-keeping for the creation of an operator." (let* ((language-definition (find-language1 language)) (type-table (language-genome-operators-by-type language-definition)) (type-vectors (gethash type type-table)) (operator-record (make-operator :name name :language language-definition :result-type type :argument-types (if (listp arglist) (mapcar #'cadr arglist) arglist) :eval-args-please evaluated :evaluator-name evaluator-name ))) (when (null type-vectors) (setq type-vectors (cons (make-array 20 :adjustable t :fill-pointer 0) (make-array 10 :adjustable t :fill-pointer 0))) (setf (gethash type type-table) type-vectors)) (vector-push-extend operator-record (car type-vectors)) (unless (listp arglist) (vector-push-extend operator-record (cdr type-vectors))) (setf (gethash name (language-operators language-definition)) operator-record))) (defmacro def-operator (name type language arglist evaluated &body body) "Define an operator for LANGUAGE called NAME returning TYPE taking ARGLIST and whether EVALUATED and running body BODY. Within BODY, the current creature is accessible through the argument this-creature-itself which is defined automatically. Apart from that, BODY is a normal Lisp defun body." ;; (format t "evaluator body is ~S~%" body) (if (listp arglist) (let ((operator-name (intern (concatenate 'string "language-" (plain-name language) "-operator-" (plain-name name))))) ;; (when (stringp (car body)) (setq body (cdr body))) `(progn (compile ',operator-name '(lambda ,(cons 'this-creature-itself (mapcar #'car arglist)) (progn ,@body))) (install-operator ',language ',name ',type ',arglist ',evaluated ',operator-name))) `(install-operator ',language ',name ',type ',arglist ',evaluated nil))) ;;;; useful bits for operators (defmacro get-state (whom key) "For creature WHOM, get the KEYed state attribute." `(gethash ,key (creature-state ,whom))) (defmacro put-state (whom key value) "For creature WHOM, set the KEYed state attribute to VALUE." `(setf (gethash ,key (creature-state ,whom)) ,value)) (defmacro get-parameter (whom key) "For creature WHOM, get the KEYed parameter, which may be taxon-wide." `(let ((bp (creature-parameters ,whom))) (if (hash-table-p bp) (multiple-value-bind (value gotit) (gethash ,key bp) (if gotit value (gethash ,key (taxon-parameters (creature-taxon ,whom))))) (gethash ,key (taxon-parameters (creature-taxon ,whom)))))) ;;;; operator interface back to the evaluator framework (defun use-locus (creature locus-key &optional force chromosome-index) "In CREATURE, run locus keyed by LOCUS-KEY if its promoter is true, or if FORCE -- an optional arg. CHROMOSOME-INDEX gives the chromosome from which to start searching for the key -- defaults to 0." (catch 'found (let ((ploidy (taxon-ploidy (creature-taxon creature))) (index-offset (if chromosome-index chromosome-index 0)) (chromosomes (creature-chromosomes creature))) (dotimes (i ploidy) (let ((locus (assoc locus-key (aref chromosomes (mod (+ i index-offset) ploidy))))) (when (not (null locus)) (throw 'found (if (or force (beval (locus-promoter locus) creature)) (beval (locus-action locus) creature) nil)))))) nil)) ;;;; metabolism etc (defvar *reporting-level* 15 "The amount of reporting to do in the logfile.") (defmacro report-at (level message &rest message-args) "If *reporting-level* is at least LEVEL, report MESSAGE with further format args if given." `(when (<= ,level *reporting-level*) (format t ,message ,@message-args))) (defun feed (creature amount) "Feed CREATURE with AMOUNT of energy." (incf (creature-energy creature) amount) (report-at 10 "~s fed by ~f going up to ~f~%" (creature-name creature) amount (creature-energy creature)) (creature-energy creature)) (defun deplete (creature amount) "Deplete from CREATURE this AMOUNT of energy." (decf (creature-energy creature) amount) (report-at 10 "~s depleted by ~f going down to ~f~%" (creature-name creature) amount (creature-energy creature)) (when (< (creature-energy creature) 0) (die creature) (creature-energy creature))) (defvar *dead-realm* (make-realm :name "The next world") "Where dead creatures go.") (defun die (creature) "Make CREATURE die i.e. remove it from its realm." (report-at 4 "~s died ~f; biography ~s~%" (creature-name creature) (creature-energy creature) (creature-biography creature)) (let ((realm (creature-realm creature))) (setf (realm-creatures realm) (delete creature (realm-creatures realm)))) (push creature (realm-creatures *dead-realm*))) (defun eat (eater eaten) "EATER eats EATEN and thus picks up its energy." (let ((efficiency (get-state eater :digestion-efficiency))) (feed eater (* (creature-energy eaten) (if efficiency efficiency 1)))) (die eaten) (report-at 3 "~s ate ~s going up to ~f~%" (creature-name eater) (creature-name eaten) (creature-energy eater)) (creature-energy eater)) (defun get-inorganic (realm key) "Get in REALM the inorganic marked by KEY." (gethash key (realm-inorganics realm))) (defun put-inorganic (realm key value) "Set in REALM the inorganic marked by KEY to VALUE." (setf (gethash key (realm-inorganics realm)) value)) ;;;; movement and position (defun move (creature) "Move CREATURE in its current direction." (with-boundaries (realm-boundaries (creature-realm creature)) (setf (creature-x creature) (max x-min (min x-max (+ (creature-x creature) (creature-dx creature))))) (setf (creature-y creature) (max y-min (min y-max (+ (creature-y creature) (creature-dy creature))))) (setf (creature-z creature) (max z-min (min z-max (+ (creature-z creature) (creature-dz creature)))))) (report-at 5 "~s moved to ~f ~f ~f~%" (creature-name creature) (creature-x creature) (creature-y creature) (creature-z creature))) (defun move-and-deplete (creature) "Move CREATURE in its current direction, using up the appropriate energy." (move creature) (let ((amount (+ (abs (creature-dx creature)) (abs (creature-dy creature)) (abs (creature-dz creature))))) (deplete creature (* (get-parameter creature :moving-effort) amount)) amount)) (defun turn (creature amount) "Turn CREATURE by AMOUNT." (psetf (creature-dx creature) (+ (* (creature-dx creature) (cos amount)) (* (creature-dy creature) (sin amount))) (creature-dy creature) (+ (* (creature-dx creature) (sin amount)) (* (creature-dy creature) (cos amount)))) (report-at 5 "~s turned to ~f ~f ~f~%" (creature-name creature) (creature-dx creature) (creature-dy creature) (creature-dz creature))) (defun turn-and-deplete (creature amount) "Turn CREATURE by AMOUNT, using up the appropriate energy." (turn creature amount) (deplete creature (* (get-parameter creature :turning-effort) (abs amount))) amount) (defun distance (a b) "Return the distance between A and B." (expt (+ (expt (- (creature-x a) (creature-x b)) 2) (expt (- (creature-y a) (creature-y b)) 2)) .5)) ;;;; breeding creatures (defun type-strict-crossover (form1 form2) "Create a pair of forms based on FORM1 and FORM2 but with a random crossover between them." (let ((new1 (copy-tree form1)) (new2 (copy-tree form2))) (values new1 new2))) (defmacro sequencep (value) "Return whether VALUE is a list, string, array or hash-table." `(or (listp ,value) (arrayp ,value) (stringp ,value) (hash-table-p ,value))) (defmacro copy-state (state) "Return a separate copy of STATE." `(if (hash-table-p ,state) (let ((oldstate ,state) (newstate (make-hash-table :test #'eq))) (maphash #'(lambda (k v) (setf (gethash k newstate) (if (sequencep v) (copy-seq v) v) )) oldstate) newstate) (copy-seq ,state))) (defun create-offspring (dam genome sire) "Create one offspring of DAM with GENOME and record SIRE in ancestry." (let* ((realm (creature-realm dam)) (taxon (creature-taxon dam)) (offspring (make-creature :name (incf *name*) :taxon (creature-taxon dam) :chromosomes genome :fitness nil :biography nil :ear nil :latest-shout-heard (car (realm-shouts realm)) :age 0 :sex (pick-random-sequence-element (taxon-sexes taxon)) :state (copy-state (creature-state dam)) :energy (taxon-initial-energy taxon) :realm realm :parameters (creature-parameters dam) :x (creature-x dam) :y (creature-y dam) :z (creature-z dam) :dx (creature-dx dam) :dy (creature-dy dam) :dz (creature-dz dam) :ancestry (cons dam sire)))) (push offspring (realm-creatures realm)))) (defun breed-d-s (dam sire litter-size) "Breed from DAM and SIRE producing LITTER-SIZE creaturelets, which go into their DAM's realm and inherit everything other than part of the genome from the DAM." #+debug (when (eq sire dam) (error "Cannot breed with self.")) #+debug (unless (eq (creature-taxon sire) (creature-taxon dam)) (error "Cannot breed between taxa.")) (let ((sire-genome (creature-chromosomes sire)) (dam-genome (creature-chromosomes dam))) (unless (evenp litter-size) (create-offspring dam (type-strict-crossover sire-genome dam-genome) sire)) (dotimes (i (floor litter-size 2)) (declare (ignore i)) (multiple-value-bind (genome1 genome2) (type-strict-crossover sire-genome dam-genome) (create-offspring dam genome1 sire) (create-offspring dam genome2 sire))))) (defun breed (dam sire litter-size) "Mate DAM and SIRE producing LITTER-SIZE creaturelets. If the taxon does not have distinct sexes, mate both ways producing a separate litter from each parent. Remember this is not called from the genetic algorithm framework, but from some operator run by an individual, which must take care of finding a mate itself. This routine is intended for calling from operator code." (if (null (creature-sex dam)) (progn (breed-d-s dam sire litter-size) (breed-d-s sire dam litter-size)) (breed-d-s dam sire litter-size))) (defun potential-mates-p (a b) "Return whether A and B are potential mates (in terms of taxa and sex)." (and (eq (creature-taxon a) (creature-taxon b)) (let ((sex-a (creature-sex a)) (sex-b (creature-sex b))) (or (and (null sex-a) (null sex-b)) (and (eq sex-a :male) (eq sex-b :female)) (and (eq sex-a :female) (eq sex-b :male)))))) (defun generic-animal-mate (creature mate) "Complete mating operation between CREATURE and MATE suitable for typical animal species." (when (and (eq (creature-sex creature) :male) (potential-mates-p creature mate) (get-state mate :receptive)) (breed-d-s mate creature (funcall (taxon-litter-size (creature-taxon mate)) mate creature)))) ;;;; communicating between creatures (defun say-to-creature (utterance creature) "Say UTTERANCE to CREATURE. This routine is intended for calling from operator code." (push utterance (creature-ear creature))) (defun shout-in-realm (utterance self) "Shout UTTERANCE for any creatures in your SELF's realm to hear. This routine is intended for calling from operator code." (push utterance (realm-shouts (creature-realm self)))) (defun listen-in-realm (self) "Get an utterance which has been uttered to us, or if there are none specifically for us, get the next shout that we haven't heard. This routine is intended for calling from operator code." (when (null (creature-ear self)) (let ((shouted-so-far (realm-shouts (creature-realm self))) (creature-earful (creature-latest-shout-heard self))) (when (not (eq creature-earful (car shouted-so-far))) (progn (do ((shouts-to-transfer shouted-so-far (cdr shouts-to-transfer))) ((eq (car shouts-to-transfer) creature-earful)) (say-to-creature (car shouts-to-transfer) self)) (setf (creature-latest-shout-heard self) shouted-so-far))))) (if (not (null (creature-ear self))) (pop (creature-ear self)) nil)) ;;;; stepping creatures and realms (defmacro step-creature (who) "Step WHO from one state to the next, that is, find its next active locus, and evaluate it." `(let* ((whom ,who) (starting-index (creature-chromosomes-active-index whom)) (starting-point (creature-chromosome-active-point whom)) (chromosomes (creature-chromosomes whom)) (point starting-point) (index starting-index) (times-round 0)) (report-at 16 "Stepping ~S~%" whom) (setf (creature-fitness whom) (catch 'triggered (loop (if (not (null (cdr point))) (setq point (cdr point)) (progn (setq index (mod (1+ index) (length chromosomes)) point (aref chromosomes index)) (when (= index starting-index) (incf times-round)) (when (>= times-round 2) (throw 'triggered nil)))) (let ((loc (car point))) (report-at 20 "Evaluating ~S for ~S..." loc whom) (let ((promoting (beval (locus-promoter loc) whom))) (report-at 20 " ~s~%" (if promoting t nil)) (push (cons loc (if promoting t nil)) (creature-biography whom)) (when promoting (report-at 15 "~S running ~S~%" whom (locus-action loc)) (throw 'triggered (beval (locus-action loc) whom))))))) (creature-chromosomes-active-index whom) index (creature-chromosome-active-point whom) point (creature-age whom) (1+ (creature-age whom))) (creature-fitness whom))) (defun step-realm (where) "Move everything in WHERE on one step." (let ((step-inorganics (realm-step-inorganics where))) (unless (null step-inorganics) (funcall step-inorganics where))) ;; (format t "~D creatures in realm: ~S~%" (length (realm-creatures where)) (realm-creatures where)) (dolist (one (realm-creatures where)) (step-creature one)) (dolist (ones (realm-sub-realms where)) (step-realm ones))) ;;;; creating initial creatures (defun choose-operator (possibilities &optional terminal-only) "Choose an operator from vector POSSIBILITIES, optionally constraining to TERMINAL-ONLY." (let ((poss (if terminal-only (cdr possibilities) (car possibilities)))) (when (null poss) (error "No suitable operator")) (aref poss (random (length poss))))) (defun random-form (operators type depth) "Create a random form for a creature with OPERATORS resulting in TYPE and allowing up to DEPTH more levels." (when (or (listp type) (vectorp type)) (setq type (elt type (random (length type))))) (let* ((operator-possibilities (lookup type operators)) (op (choose-operator operator-possibilities (zerop depth))) (subform-types (operator-argument-types op))) (if (eq subform-types :terminal) (operator-name op) (cons (operator-name op) (mapcar #'(lambda (subform-type) (random-form operators subform-type (1- depth))) subform-types))))) (defun random-locus-keys () "Make a random list of keys." (let ((keys nil)) (dotimes (i (random 100)) (declare (ignore i)) (pushnew (random 100) keys)) keys)) (defun random-chromosome (taxon) "Make up a random chromosome for TAXON." (let* ((language (taxon-language taxon)) (operators (language-genome-operators-by-type language)) (step-type (taxon-step-type taxon)) (depth (language-form-depth language)) (keys (taxon-locus-keys taxon))) (unless keys (progn (setq keys (random-locus-keys)) (setf (taxon-locus-keys taxon) keys))) (mapcar #'(lambda (locus-key) (make-locus :key locus-key :promoter (random-form operators 'boolean depth) :action (random-form operators step-type depth))) keys))) (defun random-genome (taxon) "Make up a random genome valid for TAXON." (let* ((ploidy (taxon-ploidy taxon)) (genome (make-array ploidy))) (dotimes (i ploidy) (setf (aref genome i) (random-chromosome taxon))) genome)) (defun pick-random-sequence-element (sequence) "Return any element of SEQUENCE, chosen at random." (elt sequence (random (length sequence)))) (defun create-protocreature (taxon) "Create a protocreature of TAXON." (let* ((new-state (make-hash-table :test #'eq)) (new-creature (make-creature :taxon taxon :state new-state :energy (taxon-initial-energy taxon)))) (map nil #'(lambda (entry) (setf (gethash (car entry) new-state) (cadr entry))) (taxon-default-state taxon)) new-creature)) (defun random-between (from to) "Return a random number between FROM and TO." (let ((range (abs (- to from)))) (+ (min from to) (if (zerop range) 0 (random range))))) (defun create-random-creature (protocreature) "Return a new random creature made using PROTOCREATURE." (with-boundaries (realm-boundaries (creature-realm protocreature)) (let ((taxon (creature-taxon protocreature))) (make-creature :name (incf *name*) :taxon taxon :chromosomes (random-genome taxon) :chromosome-active-point nil ; steps to somewhere real automatically first time :chromosomes-active-index 0 ; steps to somewhere real automatically first time :fitness nil :biography nil :ear nil :age 0 :sex (pick-random-sequence-element (taxon-sexes taxon)) :state (copy-state (creature-state protocreature)) :energy (creature-energy protocreature) :realm (creature-realm protocreature) :x (random-between x-min x-max) :y (random-between y-min y-max) :z (random-between z-min z-max) :dx (creature-dx protocreature) :dy (creature-dy protocreature) :dz (creature-dz protocreature) :ancestry (cons protocreature nil))))) (defvar *print-creature-genomes* nil "Whether to print creatures complete with their genomes.") (defvar *print-creature-biographies* nil "Whether to print creatures complete with their biographies.") (defun print-creature (creature stream depth) "Print CREATURE to STREAM at DEPTH." (declare (ignore depth)) (format stream "#")) (defun keyed-list-to-table (parameters) "Convert PARAMETERS to a table." (if (null parameters) nil (let ((parameter-table (make-hash-table :test #'eq))) (do () ((null parameters) parameter-table) (setf (gethash (car parameters) parameter-table) (cadr parameters)) (setq parameters (cddr parameters))) parameter-table))) (defun create-taxon (name ploidy step-type language &key locus-keys initial-energy default-state sexes parameters inorganics-setup render-as-PostScript header-PostScript) "Create and return a taxon called NAME with PLOIDY, STEP-TYPE and LANGUAGE. Optional extra keyword arguments are LOCUS-KEYS, INITIAL-ENERGY, DEFAULT-STATE, PARAMETERS, RENDER-AS-POSTSCRIPT, HEADER-POSTSCRIPT and SEXES." (unless (symbolp name) (setq name (intern name))) (when (null initial-energy) (setq initial-energy 100)) (when (null sexes) (setq sexes '( :male :female))) (let* ((language-definition (find-language language)) (taxon (make-taxon :name name :ploidy ploidy :locus-keys locus-keys :step-type step-type :default-state default-state :sexes sexes :initial-energy initial-energy :parameters (keyed-list-to-table parameters) :inorganics-setup inorganics-setup :render-as-PostScript render-as-PostScript :header-PostScript header-PostScript :language language-definition))) (setf (gethash name *all-taxa-by-name*) taxon) taxon)) (defun create-language (name &key type-evals form-depth) "Create a language called NAME." (unless (symbolp name) (setq name (intern name))) (let ((language (make-language :name name :genome-operators-by-type (make-hash-table :test #'eq) :operators (make-hash-table :test #'eq) :form-depth (if form-depth form-depth 10) :type-evals (if type-evals type-evals *default-type-evaluators*)))) (setf (gethash name *all-languages-by-name*) language) language)) (defvar *print-languages-with-operators* nil "Whether to print the operators of a language.") (defun print-language (language stream depth) "Print LANGUAGE to STREAM at DEPTH." (declare (ignore depth)) (format stream "#~S~%" (operator-name oprecord) (operator-argument-types oprecord) (operator-eval-args-please oprecord) (operator-result-type oprecord) )) (car typevector))) (language-genome-operators-by-type language)) (format stream "}")) (format stream ">")) (defun annul-language (language) "Annul the definition for LANGUAGE so it will be re-loaded when next referred to." (when (language-p language) (setq language (language-name language))) (unless (symbolp language) (setq language (intern language))) (setf (gethash language *all-languages-by-name*) nil)) ;;;; creating and linking realms (defun add-creature-to-realm (creature realm) "Add CREATURE to REALM, doing any necessary book-keeping." (let* ((taxon (creature-taxon creature))) (unless (or (memq taxon (realm-taxa realm)) (null (taxon-inorganics-setup taxon))) (funcall (taxon-inorganics-setup taxon) realm)) (push creature (realm-creatures realm)))) (defun create-and-populate-realm (name boundaries organics inorganics) "Return a new realm called NAME bounded by BOUNDARIES populated by organisms specified by ORGANICS which should be an alist of (taxon . how-many), and also containing INORGANICS." (unless (symbolp name) (setq name (intern name))) (let ((newland (make-realm :name name :boundaries (apply 'vector boundaries) :creatures nil :inorganics (keyed-list-to-table inorganics) :shouts nil :super-realm nil :sub-realms nil))) (dolist (this organics) (let ((proto (create-protocreature (find-taxon (car this)))) (count (cdr this))) (setf (creature-realm proto) newland) (when *creature-verbose* (format *terminal-io* "Creating ~D of ~S~%" count (taxon-name (creature-taxon proto))) (force-output *terminal-io*)) (dotimes (i count) (declare (ignore i)) (when *creature-verbose* (format *terminal-io* ".") (force-output *terminal-io*)) (add-creature-to-realm (create-random-creature proto) newland)) (when *creature-verbose* (format *terminal-io* "~%Created ~D of ~S~%" count (taxon-name (creature-taxon proto))) (force-output *terminal-io*)))) (setf (gethash name *all-realms-by-name*) newland) newland)) ;;;; loading and saving realms; ;;; they go in a directory tree structure starting at *realms-directory* (defvar *realms-directory* "realms" ;; I thought it should manage the form below! ;; (make-pathname :directory '(:relative "realms")) "Where to find realms, by name, hierarchically.") (defun hierarchical-name-of-realm (realm) "Return the hierarchical name of REALM." (when (symbolp realm) (setq realm (gethash realm *all-realms-by-name*))) (let ((super-realm (realm-super-realm realm))) (if (null super-realm) (list (plain-name (realm-name realm))) (cons (plain-name (realm-name realm)) (hierarchical-name-of-realm super-realm))))) (defun hierarchical-name-to-file-and-directory (name) "Split hierarchical NAME into file and directory parts." (let* ((r (reverse name)) (file (car r)) (directory (nreverse r))) (values file directory))) (defun pathname-of-realm (realm) "Return where REALM will be loaded and saved." (multiple-value-bind (file directory-list) (hierarchical-name-to-file-and-directory (hierarchical-name-of-realm realm)) (make-pathname :name file :directory (cons :relative (cons *realms-directory* directory-list))))) (defun ensure-one-directory-exists (d) "Ensure D exists. Assume its parent directories do." (unless (probe-file d) (system:make-directory d))) (defun ensure-directory-exists (path) "Make sure the directory PATH in exists." (let* ((directory-list (pathname-directory path)) (directory-kind (car directory-list)) (list-head (list (cadr directory-list))) (list-tail list-head)) (do ((list-rest (cddr directory-list) (cdr list-rest))) ((null list-rest)) (format t "Directory list is ~S~%" list-head) (ensure-one-directory-exists (make-pathname :directory (cons directory-kind list-head))) (setq list-tail (cdr (rplacd list-tail (cons (car list-rest) nil))))) (ensure-one-directory-exists (make-pathname :directory directory-list)))) (defmacro find-realm1 (realm) "Find REALM; don't try to load it if not found." `(gethash ,realm *all-realms-by-name*)) (defun find-realm (realm) "Ensure the REALM is loaded." (if (or (realm-p realm) (null realm)) realm (if (find-realm1 realm) (find-realm1 realm) (let ((realm-name realm) (realm-file-name (merge-pathnames (make-pathname :name (plain-name realm) :type "lisp") *realm-directory*))) ;; this file should contain a call to create-realm to do its book-keeping (load realm-file-name) (setq realm (find-realm1 realm)) (unless (realm-p realm) (error "Loading ~S did not define realm ~S" realm-file-name realm-name)) realm)))) (defun genome-as-list (genome) "Convert GENOME to a list for convenient dumping." (map 'list #'(lambda (chromo) (map 'list #'(lambda (locus) (list (locus-key locus) (locus-promoter locus) (locus-action locus))) chromo)) genome)) (defun genome-from-list (glist) "Convert GLIST to a genome." (map 'array #'(lambda (chromolist) (map 'list #'(lambda (locuslist) (make-locus (first locuslist) (second locuslist) (third locuslist))) chromolist)) glist)) (defun state-as-list (state) "Convert STATE to a list for convenient dumping." (let ((result nil)) (maphash #'(lambda (k v) (push (cons k v) result)) state) result)) (defun state-from-list (slist) "Convert SLIST to a creature state." (let ((newstate (make-hash-table :test #'eq))) (map 'nil #'(lambda (pair) (setf (gethash (car pair) newstate) (cdr pair))) slist) newstate)) (defun save-creature (creature &optional place) "Save CREATURE to the appropriate file in realm directory PLACE. PLACE is worked out from CREATURE if not given or if null." (unless place (setq place (pathname-of-realm (creature-realm creature)))) (with-open-file (creaturestream (merge-pathnames (make-pathname :type "lisp" :name (plain-name (format nil "~A" (creature-name creature)))) place) :direction :output :if-exists :supersede :if-does-not-exist :create) (format creaturestream ";; creature ~A~%~S~%" (creature-name creature) `(create-creature-in-realm ,(creature-name creature) ,(taxon-name (creature-taxon creature)) ,(realm-name (creature-realm creature)) :sex ,(creature-sex creature) :energy ,(creature-energy creature) :genome (genome-from-list ',(genome-as-list (creature-chromosomes creature))) :state (state-from-list ',(state-as-list (creature-state creature))) ) ))) (defun list-creature-names (realm) "List the creature names in REALM." (mapcar #'(lambda (creature) (make-pathname :name (plain-name (format nil "~A" (creature-name creature))) :type "lisp")) (realm-creatures realm))) (defun save-realm (realm) "Save REALM and its sub-realms, at the appropriate place in *realms-directory*" (let* ((place (pathname-of-realm realm)) (realm-file-name (merge-pathnames "realm.lisp" place)) (creatures (realm-creatures realm)) (super (realm-super-realm realm)) ) (ensure-directory-exists place) (mapcar #'(lambda (creature) (save-creature creature place)) creatures) (with-open-file (realmstream realm-file-name :direction :output :if-exists :supersede :if-does-not-exist :create) (when *creature-verbose* (format t "Saving realm to ~A~%" realm-file-name)) (format realmstream ";; realm ~A~%~S~%;; and of realm ~A~%" (realm-name realm) `(create-realm ,(realm-name realm) :super-realm (find-realm ,(if super (realm-name super) nil)) :load-creatures-directory ,place :load-creatures ',(list-creature-names realm) ) (realm-name realm))))) (defun create-creature-in-realm (name taxon realm-name &key sex energy genome state parameters) "Create creature called NAME of TAXON in REALM with parts filled in from other (keyword) arguments." (let* ((realm (find-realm1 realm-name)) (creature (make-creature :name name :realm realm :taxon (find-taxon1 taxon) :fitness nil :biography nil :sex sex :chromosomes genome :energy energy :parameters (keyed-list-to-table parameters) :state state))) (push creature (realm-creatures realm)) creature)) (defun create-realm (name &key super-realm load-creatures-directory load-creatures) "Create a realm called NAME with various things specified." (unless (symbolp name) (setq name (intern name))) (let* ((realm (make-realm :name name :super-realm super-realm))) (setf (gethash name *all-realms-by-name*) realm) (map nil #'(lambda (saved-creature-name) (load (merge-pathnames (make-pathname :name saved-creature-name :type "lisp") load-creatures-directory))) load-creatures) realm)) (defvar *taxa-directory* (make-pathname :directory '(:relative "taxa")) "Where to find taxa, by name.") (defmacro find-taxon1 (taxon) "Find TAXON; don't try to load it if not found." `(gethash ,taxon *all-taxa-by-name*)) (defun find-taxon (taxon) "Ensure the TAXON is loaded." (if (or (taxon-p taxon) (null taxon)) taxon (if (find-taxon1 taxon) (find-taxon1 taxon) (let ((taxon-name taxon) (taxon-file-name (merge-pathnames (make-pathname :name (plain-name taxon) :type "lisp") *taxa-directory*))) ;; this file should contain a call to create-taxon to do its book-keeping (load taxon-file-name) (setq taxon (find-taxon1 taxon)) (unless (taxon-p taxon) (error "Loading ~S did not define taxon ~S" taxon-file-name taxon-name)) (find-language (taxon-language taxon)) taxon)))) (defvar *languages-directory* (make-pathname :directory '(:relative "languages")) "Where to find languages, by name.") (defun find-language (language) "Ensure the LANGUAGE is loaded." (if (or (language-p language) (null language)) language (if (find-language1 language) (find-language1 language) (let ((language-name language) (language-file-name (merge-pathnames (make-pathname :name (plain-name language) :type "lisp") *languages-directory*))) ;; this file should contain a call to create-language to do its book-keeping (load language-file-name) (setq language (find-language1 language)) (unless (language-p language) (error "Loading ~S did not define language ~S" language-file-name language-name)) language)))) ;;;; global runs, top-level entry points, etc etc (defvar *world* nil "The most recently run top-level realm.") (defun describe-realm (realm) "Output a description of REALM." (when (symbolp realm) (setq realm (gethash realm *all-realms-by-name*))) (print realm)) (defun render-realm-as-PostScript (realm ps-file size-x size-y &key label) "Output a PostScript picture of REALM into PS-FILE at SIZE-X, SIZE-Y points." (when (symbolp realm) (setq realm (gethash realm *all-realms-by-name*))) (when *creature-verbose* (format t "Describing realm in postscript to ~A~%" ps-file)) (with-open-file (*standard-output* ps-file :direction :output :if-does-not-exist :create :if-exists :supersede) (format t "%!PS~%% picture of realm ~S~%" (plain-name (realm-name realm))) (format t "save /realmsave exch def~%") (format t "/Helvetica 10 selectfont~%") (format t "/m /moveto load def /l /lineto load def /s /stroke load def /n /newpath load def /c /closepath load def /G /gsave load def /g /grestore load def /t /translate load def~%") (format t "/x {-1 0 m 1 0 l s 0 -1 m 0 1 l s } bind def~%") (let ((taxa nil)) (format t "% Headers for taxa:~%") (dolist (b (realm-creatures realm)) (pushnew (creature-taxon b) taxa)) (dolist (tax taxa) (let ((ps (taxon-header-PostScript tax))) (if ps (format t "%% header for ~S:~%~A~%" (taxon-name tax) ps) (format t "~%% no header for ~S~%" (taxon-name tax))))) (format t "% End of headers for taxa~%")) (with-boundaries (realm-boundaries realm) (when label (format t "~%0 0 moveto (~S) show~%" label)) (format t "~%n ~F ~F m ~F ~F l ~F ~F l ~F ~F l c s~%" x-min y-min x-max y-min x-max y-max x-min y-max) (let ((x-size (- x-max x-min)) (y-size (- y-max y-min)) ;; (z-size (- z-max z-min)) ) (format t "~F ~F translate ~F ~F scale~%" (- x-min) (- y-min) (* size-x (/ 1.0 x-size)) (* size-y (/ 1.0 y-size))) (dolist (b (realm-creatures realm)) (format t "~F ~F t G n~%" (creature-x b) (creature-y b)) (let ((render (taxon-render-as-PostScript (creature-taxon b)))) (if render (funcall render b) (format t "x~%"))) (format t "~%g~%")))) (format t "realmsave restore showpage~%"))) (defun run-realm (realm steps) "Load REALM and run it for STEPS then save it." (setq *world* (find-realm realm)) (dotimes (step steps) (format t "Step ~D (~D individuals):~%" step (length (realm-creatures *world*))) (step-realm *world*)) (save-realm realm)) (defun run-creatures-world (worldspec psbasename ntrace) "Run a creatures world as specified by WORLDSPEC, tracing in PostScript to PSBASENAME files every NTRACE steps." (setq *world* (create-and-populate-realm (cadr (assoc :name worldspec)) (cadr (assoc :boundaries worldspec)) (cadr (assoc :organics worldspec)) (cadr (assoc :inorganics worldspec)))) (let ((nsteps (cadr (assoc :steps worldspec)))) (format t "Starting run of ~D steps~%" nsteps) (when *creature-verbose* (format *terminal-io* "Starting run of ~D steps~%" nsteps)) (render-realm-as-PostScript *world* (format nil psbasename 0) 600 800) (dotimes (step nsteps) (format t "Step ~D (~D individuals):~%" step (length (realm-creatures *world*))) (when *creature-verbose* (format *terminal-io* "Step ~D (~D individuals):~%" step (length (realm-creatures *world*)))) (step-realm *world*) (when (zerop (mod step ntrace)) (render-realm-as-PostScript *world* (format nil psbasename step) 600 800 :label (format nil "Realm at step ~D" step))) ;; (when (zerop (mod step ntrace)) (describe-realm *world*)) ) (save-realm *world*) (describe-realm *world*) (render-realm-as-PostScript *world* (format nil psbasename (1+ nsteps)) 600 800))) (defun run-creatures-file (infilename outfilename psbasename ntrace) "Run the Creatures world in INFILENAME and output results to OUTFILENAME and PostScript to PSBASENAME every NTRACE steps." (with-open-file (*standard-output* outfilename :direction :output :if-does-not-exist :create :if-exists :supersede) (format t "Log of run of ~S~%" infilename) (with-open-file (*standard-input* infilename :direction :input) (run-creatures-world (read) psbasename ntrace)))) ;;; end of creatures.lisp