;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; push.lisp ;; a programming language for evolutionary computation ;; c) 2000-2001, Lee Spector (lspector@hampshire.edu) ;; ;; distribution location: http://hampshire.edu/lspector/push.html ;; for version information see revision history below #| The basic concepts of the Push programming language are outlined in: Spector, L. 2001. Autoconstructive Evolution: Push, PushGP, and Pushpop. In Spector, L., E. Goodman, A. Wu, W.B. Langdon, H.-M. Voigt, M. Gen, S. Sen, M. Dorigo, S. Pezeshk, M. Garzon, and E. Burke, editors, Proceedings of the Genetic and Evolutionary Computation Conference, GECCO-2001. San Francisco, CA: Morgan Kaufmann Publishers. More detail, including a Push language reference, can be found in the (currently in press) journal article: Spector, L., and A. Robinson. 2002. Genetic Programming and Autoconstructive Evolution with the Push Programming Language. Genetic Programming and Evolvable Machines. Volume 3, Number 1. The comments in this file assume familiarity with the language as described in the above publications. The Push interpreter implemented in this file can be used independently but it is designed primarily for use with the PushGP genetic programming system or with the Pushpop autoconstructive evolution system. This code is written in Common Lisp. It has been tested in Macintosh Common Lisp and CMU Common Lisp; it should work unchanged in any modern Common Lisp environment. This code is being made available for non-commercial educational and research uses only. To Use ------ 0. Finish reading this comment. 1. Compile/load random.cl (a seedable random number generator by Chris McConnell). 2. Compile/load this file. 3. Try the examples at the end. 4. Read the parameter definitions near the beginning. 5. Read the type definitions and method implementations near the end. 6. Read the definitions in the "interpreter" section. 7. Read the rest if you want. Miscellaneous Notes ------------------- There is a stack for each defined type. There is also a variable binding space associated with each type, and the same variable name can be used simultaneously for several types (naming different variables that contain different values). A program is run by calling RUNPUSH, which pushes the code on the code stack and evaluates it. Results of the program, be they numbers or code or of other types, are to be found on the stacks at the end of the run. The RUNPUSH function takes a program and a list of (TYPE VALUE) pairs; it pushes the values on the specified stacks and then pushes and executes the code. See the examples at the end of the file for details. The PRINT-STACKS function prints the contents of the stacks, so a program can normally be tested with a call to RUNPUSH followed by a call to PRINT-STACKS. If the relevant stacks contain insufficient arguments for an instruction then the instruction is skipped. The type stack is not popped in determining which method to apply. All other arguments are popped after use. Method implementations (the type-specific code to execute for instructions) are named with a leading "&" but this is just a convention to make them stand out. Seeds are pre-specified chunks of code that can appear in random code (through an ephemeral random constant mechanism). These can be single instructions (to fortify the soup) or more complex expressions. No seeds are defined in the distribution version of this file but you might want to add some depending on your application. The instructions OTHER, ELDER, NEIGHBOR, and OTHER-TAG are intended for use with Pushpop, an autoconstructive evolution system. In that context they return code of other programs in the evolving population. This file implements push as a language that is independent of pushpop (or of any evolutionary computation system), so the instructions in question may have no reasonable interpretation. Dummy functions FIND-OTHER, FIND-ELDER, FIND-NEIGHBOR, and FIND-OTHER-TAG are provided for the instructions here; these are re-defined by pushpop in ways that make sense relative to its population structure. If pushpop is not being used then OTHER and its friends should be commented out of the functions specification for the expression type. The CHILD type is also intended for use with pushpop and should be commented out if not needed. The things to comment/uncomment are the type definition, the CHILD symbol in *typestack-bottom*, and any seeds containing CHILD. (Similar advice applies for deactivating/activating other types, though for some types you will need to comment out/uncomment additional instructions that access the type.) Numeric instructions are hacked in various ways to prevent errors (such as divisions by zero) and a function called keep-number-reasonable is used to prevent overflows. See comments in the functions for details. The types and instructions defined in this distribution are only those that were needed for experiments with PushGP and Pushpop -- no attempt has been made to be exhaustive or complete in any meaningful sense. It should be a simple matter, however, to add additional types and instructions using the existing definitions as models. The number of "points" in a program is the number of atoms plus the number of pairs of parentheses. The limit on code size, *max-points-in-program*, is enforced for the results of all code manipulation instructions. Generally the instruction will have no effect if the result would violate the limit. The "named" factorial example in the GECCO-2001 paper will not work as published -- when the paper was written the NAME data type was treated specially, but it has since been made more normal. Updated factorial examples are included below. If you use CMU Common Lisp you can cut down the number of garbage collection messages and improve efficiency by including something like: #+cmu(setq extensions:*bytes-consed-between-gcs* 100000000) If you get warnings that this is too large you might remove one of the zeros. To turn off all of the garbage collection messages use: #+cmu(setq extensions:*gc-verbose* nil) Defaults in the Distribution Copy --------------------------------- This distribution copy of push.lisp has defaults appropriate for use with the PushGP genetic programming system. In particular: - The following stochastic instructions are commented out: RAND, PERTURB, MIX-ATOMS - The CHILD type is commented out. - The following Pushpop-related instructions are commented out: OTHER, ELDER, NEIGHBOR, and OTHER-TAG - No seeds are defined. To Do ----- - Make it easier to turn types on and off; this has impacts in several places (e.g. on the type stack bottom). - Add stack depth limits; memory overflows in PushGP may be due to exponential stack growth. - Fix many glaring inefficiencies, including - Unnecessary coercion of things to lists, for example in &list, where the answer can be deduced from the fact that coercion would be necessary. - Some calls to copy-tree may be unnecessary, but better safe than sorry on this one so be careful. - Figure out a good way to avoid useless growth of the code stack (maybe a CLEAR instruction, possibly for all types?). - Fix terminology with respect to push-function/instruction/method etc. - Resolve some open issues about names... augmentation of list/use in random code aside from ephemeral random constants? Revision History ---------------- YYYYMMDD 20010203 - First revision for limited distribution. 20010204 - Made rules for when arguments are popped consistent. - Found and eliminated a bug in &randexp. - NOTE that the above revisions forced changes in the examples and may break any push code written or evolved before this date. - Excised global *copy-error-probability-denominator*. - Overhauled random code generation. - Several stylistic and organizational improvements. 20010331 - Seeds removed. - Utilities: with-atoms, with-atoms-uniform-crossover, flatten - Push functions replace-atoms and mix-atoms - Fixed MAJOR BUG in &PERTURB 20010426 - Fixed bug in &= for Booleans 20010531 - Added discrepancy utilities and &DISCREPANCY - Enhanced KEEP-NUMBER-REASONABLE (per suggestion of Alan Robinson) 20010608 - Changed prefix for RAND-generated names to PUSH-VAR- 20010627 - Increased limit in KEEP-NUMBER-REASONABLE to 100000000000000000000 for factorial problems. 20010711 - Cleaned up for first public distribution. 20010713 - Fixed bug in INTEGER->BOOLEAN conversion (thanks Alan Robinson) 20010720 - Fixed bug in &PULL when there was only one INTEGER on the stack. 20010807 - Added pulldup. 20010813 - Fixed bug (truncation) in FLOAT->FLOAT conversion. 20011117 - Updated comments on &NULL and &ATOM. 20011129 - Revised comments for new on-line distribution. 20011224 - Added sin, cos, and tan to float type. Added min, max to number type. 20020401 - Fixed bug in Max, reported by Una-May O'Reilly. 20020403 - Added FLOAT to *TYPESTACK-BOTTOM* (should have been done with 20011224 changes but wasn't necessary before then). Thanks to Chris Perry for reporting this issue. Fixed bugs in sin, cos, and tan (they were requiring an extra, unused argument to be on the stack). |# ;; possible optimization declarations ;(declaim (optimize (speed 3) (safety 1) (space 0) (debug 0))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; parameters (defparameter *max-points-in-program* 100 "The maximum number of points that can be in any expression pushed on an expression stack.") (defparameter *max-points-in-random-expressions* 25 "The maximum number of points in an expression produced by the expression method for the RAND instruction.") (defparameter *random-int-limit* 10 "Constrains the range of integers that can be produced by the integer method for the rand instruction or by ephemeral random integer constants.") (defparameter *random-float-limit* 1.0 "Constrains the range of floating point numbers that can be produced by the float method for the rand instruction or by ephemeral random float constants.") (defparameter *new-erc-symbol-probability* 0.001 "Determines the probability that the selection of the ephemeral random symbol constant will produce and return a new symbol.") (defparameter *ephemeral-random-constant-generators* '(ephemeral-random-integer ephemeral-random-float ephemeral-random-boolean ephemeral-random-symbol ;ephemeral-random-seed ) "A list of all ephemeral random constant names.") (defparameter *evalpush-limit* 1000 "The maximum number of points that will be executed in a single top-level call to runpush.") (defparameter *evalpush-time-limit* 1.0 "The maximum number of seconds that will be devoted to a single top-level call to runpush. The cut-off mechanism is not pre-emptive so the call may really take a bit more time.") (defparameter *enforce-evalpush-time-limit* nil "Time limits on runpush will be be enforced only if this is true.") (defparameter *push-names* nil "The initial list of name constants that can appear in random expressions. This may be augmented by ephemeral random constant generation and possibly by the name method of the RAND instruction. If you allow augmentation you should think about when you want to re-initialize this.") (defvar *random-seeds* (list 0 0) "A list of two integers, the first of which must be 0 <= n <= 31328, and the second of which must be 0 <= n <= 30081. These are used to seed the random number generator.") (defparameter *track-calls* t "Determines whether or not the instruction-call-tracking system will track instruction calls.") (defparameter *typestack-bottom* (list 'integer 'float 'boolean 'code #|'child|# 'type 'name) "The bottom of the type stack, appended to the stack of the type type before type lookups.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; global variables (defvar *instruction-set* nil "The set of all valid push instructions. This is constructed by complete-push-configuration.") (defvar *evalpush-count* 0 "Tracks the number of point evaluations in the current call to runpush.") (defvar *evalpush-expiration-time* 0 "Stores the cutoff time for runpush time limits if they are being enforced.") (defvar *pushtypes* nil "All types in the current push type hierarchy. Augmented by defpushtype and reset by initialize-pushtype-system.") (defvar *pushtype-hashtable* (make-hash-table) "Stores the pushtype data structures for faster access.") (defvar *concrete-pushtype-names* nil "A list of only the concrete (non-abstract) push types.") (defvar *push-functions* nil "A list of all functions that have implemented methods for the current pushtypes. This is a subset of the *instruction-set*.") (defvar *quote-destination* nil "Stores the type to which the next evaluated expression will be quoted. This will be nil when no quote is pending.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; general utilities (defun proper-list (l) "Returns t only for proper (non-dotted) lists." (if (not (listp l)) nil (if (null (cdr l)) t (proper-list (cdr l))))) ;; tests/examples ;(proper-list '(1 2 3)) ;(proper-list '(1 . 2)) ;(proper-list nil) ;(proper-list 2) (defun proper-tree (tree) "Returns t only for proper (non-dotted) trees." (if (null tree) t (if (not (proper-list tree)) nil (and (or (not (listp (car tree))) (proper-tree (car tree))) (proper-tree (cdr tree)))))) (defun improper (thing) "Returns t if thing is a tree containing dots." (and (listp thing) (not (proper-tree thing)))) (defun contains-subtree (tree subtree) "Returns t if tree contains subtree, using equalp for comparisons. Inefficient in several ways!" (or (equalp tree subtree) (not (equalp tree (subst (gensym) subtree tree :test #'equalp))))) (defun containing-subtree (tree subtree) "If tree contains subtree then this function returns the smallest subtree of tree that contains but is not equal to the first instance of subtree. For example, (containing-subtree '(b (c (a)) (d (a))) '(a)) => (C (A)). Returns nil if tree does not contain subtree." (cond ((not (listp tree)) nil) ((null tree) nil) ((member subtree tree :test #'equalp) tree) (t (some #'(lambda (smaller-tree) (containing-subtree smaller-tree subtree)) tree)))) (defun ensure-list (thing) "Returns thing if it is a list; otherwise returns a list containing thing." (if (listp thing) thing (list thing))) (defmacro until (test &rest body) "Perform the body of code until test returns true." `(do () (,test) ,@body)) (defun safe-length (anything) "Answers 0 for anything that is not a list." (if (listp anything) (length anything) 0)) (defun count-points (tree) "Returns the number of points in tree, where each atom and each pair of parentheses counts as a point." (if (consp tree) ;; reduce is faster than apply here (+ 1 (reduce #'+ (mapcar #'count-points tree))) 1)) (defun code-at-point-recursive (tree point-index) "A utility for code-at-point. Assumes point-index is in range." (if (zerop point-index) tree (let ((subtrees tree) (points-so-far 1)) (do ((points-in-first-subtree (count-points (first subtrees)) (count-points (first subtrees)))) ((< point-index (+ points-so-far points-in-first-subtree)) (code-at-point-recursive (first subtrees) (- point-index points-so-far))) (incf points-so-far points-in-first-subtree) (setq subtrees (rest subtrees)))))) (defun code-at-point (tree point-index) "Returns a subtree of tree indexed by point-index in a depth first traversal." (if (null tree) nil (code-at-point-recursive tree (abs (mod point-index (count-points tree)))))) (defun insert-code-at-point-recursive (tree point-index new-subtree) "A utility for insert-code-at-point. Assumes point-index is in range." (if (zerop point-index) new-subtree (let ((skipped-subtrees nil) (remaining-subtrees tree) (points-so-far 1)) (do ((points-in-first-subtree (count-points (first remaining-subtrees)) (count-points (first remaining-subtrees)))) ((< point-index (+ points-so-far points-in-first-subtree)) (append skipped-subtrees (list (insert-code-at-point-recursive (first remaining-subtrees) (- point-index points-so-far) new-subtree)) (rest remaining-subtrees))) (incf points-so-far points-in-first-subtree) (setq skipped-subtrees (append skipped-subtrees (list (first remaining-subtrees)))) (setq remaining-subtrees (rest remaining-subtrees)))))) (defun insert-code-at-point (tree point-index new-subtree) "Returns a copy of tree with the subtree formerly indexed by point-index (in a depth-first traversal) replaced by new-subtree." (if (null tree) new-subtree (insert-code-at-point-recursive tree (abs (mod point-index (count-points tree))) new-subtree))) (defun randint (n) "Calls the random-integer function from random.cl to produce a random integer between 0 (inclusive) and n (exclusive)." (random::random-integer n)) (defun randfloat (n) "Calls the random-integer function from random.cl to produce a random float between 0 and n." (* 1.0L0 (random::random-float n))) (defun keep-number-reasonable (n) "Returns n unless n is 'unreasonably' large or small in magnitude, in which case it returns the closest 'reasonable' value." (let* ((big-pos (* (if (integerp n) 1 1.0) 100000000000000000000)) (big-neg (- big-pos))) (cond ((> n big-pos) big-pos) ((< n big-neg) big-neg) ((and (not (integerp n)) (< n (/ 1 big-pos)) (> n (/ 1 big-neg))) 0.0) (t n)))) (defun dirty-copy (l copy-error-probability-denominator) "Returns a stochastically perturbed copy of the provided tree l, where the probability of an atom being perturbed is set by copy-error-probability-denominator. A value of :infinite for copy-error-probability-denominator means that no perturbations will occur. A value of 100 means that each atom has a 1/100 probability of being copied incorrectly, etc." (let ((result (copy-tree l)) (points (count-points l))) (unless (eq copy-error-probability-denominator :infinite) (dotimes (point points) (when (zerop (randint copy-error-probability-denominator)) (let ((subtree (code-at-point result point))) (when (atom subtree) ;; more generally should test for terminal (let ((new-instruction (expand-erc (random-element *instruction-set*)))) (when (atom new-instruction) ;; only use if it's an atom (setq result (insert-code-at-point result point new-instruction))))))))) result)) (defun with-atoms (tree atoms) "Returns a copy of tree with all of its atoms replaced with the atoms in the provided list of atoms. The first atom in tree will be replaced with the first atom in atoms, the second with the second, etc., wrapping around to the beginning of atoms if necessary. If atoms is nil then tree is returned unchanged." (if (null atoms) tree (let ((atom-counter 0) (num-atoms (length atoms))) (labels ((with-atoms-recursive (thing) (cond ((null thing) thing) ((atom thing) (prog1 (nth (mod atom-counter num-atoms) atoms) (incf atom-counter))) (t (cons (with-atoms-recursive (car thing)) (with-atoms-recursive (cdr thing))))))) (with-atoms-recursive tree))))) (defun with-atoms-uniform-crossover (tree atoms1 atoms2) "Returns a copy of tree with all of its atoms replaced with the atoms in one of the provided lists of atoms. The first atom in tree will be replaced with the first atom in one of the lists, the second with one of the seconds, etc., wrapping around to the beginning of the lists if necessary. The choice of which list of atoms to use is random for each atom replaced. If one of the lists of atoms is nil then tree is returned unchanged." (if (or (null atoms1) (null atoms2)) tree (let ((atom-counter 0) (num-atoms1 (length atoms1)) (num-atoms2 (length atoms2))) (labels ((with-atoms-recursive (thing) (cond ((null thing) thing) ((atom thing) (if (zerop (randint 2)) (prog1 (nth (mod atom-counter num-atoms1) atoms1) (incf atom-counter)) (prog1 (nth (mod atom-counter num-atoms2) atoms2) (incf atom-counter)))) (t (cons (with-atoms-recursive (car thing)) (with-atoms-recursive (cdr thing))))))) (with-atoms-recursive tree))))) ;; from OnLisp(Graham) (defun flatten (x) (labels ((rec (x acc) (cond ((null x) acc) ((atom x) (cons x acc)) (t (rec (car x) (rec (cdr x) acc)))))) (rec x nil))) (defun elapsed-realtime-seconds () "Returns the number of seconds the operating system has been running." (/ (get-internal-real-time) internal-time-units-per-second)) (defun random-element (list) "Returns a random element of the list." (nth (randint (length list)) list)) (defun shuffle (list) "Returns a randomly re-ordered copy of list." (let ((result nil)) (do () ((null list) result) (let* ((which (randint (length list))) (it (nth which list))) (push it result) (setq list (remove it list :count 1)))))) (defun decompose (number max-parts) "Returns a list of at most max-parts numbers that sum to number. The order of the numbers is not random (you may want to shuffle it)." (if (or (<= max-parts 1) (<= number 1)) (list number) (let ((this-part (1+ (randint (- number 1))))) (cons this-part (decompose (- number this-part) (- max-parts 1)))))) (defun all-items (list) "Returns a list of all of the items in list, where sublists and atoms all count as items. Will contain duplicates if there are duplicates in the list." (cons list (if (listp list) (apply #'append (mapcar #'all-items list)) nil))) (defun discrepancy (list1 list2) "Returns a measure of the discrepancy between list1 and list2. This will be zero if list1 and list2 are equalp, and will be higher the 'more different' list1 is from list2. The calculation is as follows: 1. Construct a list of all of the unique items in both of the lists (where uniqueness is determined by equalp). Sublists and atoms all count as items. 2. Initialize the result to zero. 3. For each unique item increment the result by the difference between the number of occurrences of the item in list1 and the number of occurrences of the item in list2. 4. Return the result." (let* ((items1 (all-items list1)) (items2 (all-items list2)) (unique-items (remove-duplicates (append items1 items2) :test #'equalp)) (sum 0)) (dolist (item unique-items) (incf sum (abs (- (count item items1 :test #'equalp) (count item items2 :test #'equalp))))) sum)) #| (discrepancy '(a b c d) '(a b c d) ) (discrepancy '(a b c d e) '(a b c d e) ) (discrepancy '(a b c d e) '(a b c d) ) |# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; random code generation (defun random-code-with-size (points) "Returns a random expression containing the given number of points." (if (< points 2) (expand-erc (random-element *instruction-set*)) (let ((elements-this-level (shuffle (decompose (- points 1) (- points 1))))) (mapcar #'random-code-with-size elements-this-level)))) (defun random-code (max-points) "Returns a random expression containing max-points or less points." (let ((actual-points (+ 1 (randint (- max-points 1))))) (random-code-with-size actual-points))) #| ;; for testing random code generation (defun testrand (limit howmany) (let ((expressions nil)) (dotimes (i howmany) (push (random-code limit) expressions)) (float (/ (reduce #'+ (mapcar #'count-points expressions)) howmany)))) |# (defun expand-erc (symbol) "Returns symbol if it does not name an ephemeral random constant generator. Returns the result of running the named ephemeral random constant generator otherwise. This should moudularized." (case symbol (ephemeral-random-integer (- (randint (* 2 *random-int-limit*)) *random-int-limit*)) (ephemeral-random-float (- (randfloat (* 2 *random-float-limit*)) *random-float-limit*)) (ephemeral-random-boolean (if (zerop (randint 2)) nil t)) (ephemeral-random-symbol (if (or (null *push-names*) (> *new-erc-symbol-probability* (randfloat 1))) (let ((new-symbol (gentemp "ERC-VAR-"))) (push new-symbol *push-names*) new-symbol) (random-element *push-names*))) (ephemeral-random-seed (copy-tree (random-element (list ;; list any seeds here )))) (otherwise symbol))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; data tracking system for tracking instruction calls ;; The tracking data is stored in a hash table defined in a closure ;; within which all of the tracking functions are defined. (let ((tracking-data (make-hash-table))) (defun track (thing) "Records an instance of thing in the tracking data." (if (gethash thing tracking-data) (incf (gethash thing tracking-data)) (setf (gethash thing tracking-data) 1))) (defun clear-tracking-data () "Clears the tracking data." (setq tracking-data (make-hash-table))) (defun get-tracking-data () "Returns a list of all of the tracking data." (let ((data nil)) (maphash #'(lambda (key val) (push (list key val) data)) tracking-data) data))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; type system data structures and utilities ;; Types are defined with calls to the defpushtype macro. ;; Complete-push-configuration must be called after the last call ;; to defpushtype. (defstruct pushtype name ; the name of the type parents ; types from which this type inherits functionality abstract ; if an abstract type this should be T, if concrete then NIL stack ; storage for the stack for this type default ; a default value, to be returned by GET for unbound variables functions ; (name implementation) pairs for functions implemented for this type bindings ; stores variable bindings of this type for SET and GET ) (defun initialize-pushtype-system () "Must be called before any calls to defpushtype. Can be called again to re-initialize the type system, though complete-push-configuration must subsequently be called (presumably after re-defining some types) before use." (setq *pushtypes* nil)) ;; INITIALIZE IT NOW (initialize-pushtype-system) (defun find-pushtype (name) "Returns the pushtype structure with the given name." (gethash name *pushtype-hashtable*)) (defun init-push-stacks () "Initializes the stacks and bindings for all of the types." (dolist (type *pushtypes*) (unless (pushtype-abstract type) (setf (pushtype-stack type) nil) (setf (pushtype-bindings type) nil)))) (defun print-stacks () "Prints the stacks for all of the defined push types." (dolist (type *pushtypes*) (unless (pushtype-abstract type) (format t "~%~A STACK: ~A" (pushtype-name type) (pushtype-stack type)))) (format t "~%") (values)) (defmacro defpushtype (name (&rest parents) &key (abstract nil) (default nil) (functions nil)) "Defines a new pushtype; see documentation of the pushtype structure." `(progn (push (make-pushtype :name ',name :parents ',parents :abstract ',abstract :stack nil :default ,default :functions ',functions ;; list of (fn impl) pairs ;; implementations name functions of one arg, a type :bindings nil) *pushtypes*) ',name)) (defun complete-push-configuration () "Should be called after all DEFPUSHTYPE forms. Initializes many globals." ;; seed the random number generator with the provided seeds (random::seed-state (first *random-seeds*) (second *random-seeds*)) ;; initialize the list of all push functions (setq *push-functions* nil) (dolist (type *pushtypes*) (dolist (pair (pushtype-functions type)) (pushnew (first pair) *push-functions*))) ;; initialize the list of concrete types (setq *concrete-pushtype-names* nil) (dolist (type *pushtypes*) (unless (pushtype-abstract type) (push (pushtype-name type) *concrete-pushtype-names*))) ;; initialize pushtype hashtable (setq *pushtype-hashtable* (make-hash-table)) (dolist (type *pushtypes*) (setf (gethash (pushtype-name type) *pushtype-hashtable*) type)) ;; initialize instruction set (setq *instruction-set* (append *ephemeral-random-constant-generators* ;; random literals *push-functions* ;; defined functions *concrete-pushtype-names* ;; type literals ;; direct enhancement of the soup could go here ))) ;; add *push-names*? (defun applicable (function-name type) "Returns the name of the implementation function if the named push-function can be applied to the given push-type." (let ((name-implementation-pair (find function-name (pushtype-functions type) :key #'first))) (if name-implementation-pair (second name-implementation-pair) (if (null (pushtype-parents type)) nil (some #'(lambda (parent) (applicable function-name (find-pushtype parent))) (pushtype-parents type)))))) (defun instructions-for-type (typename) "Returns a list of all of the instructions with methods implemented for or inherited by the named type." (remove-if-not #'(lambda (f) (applicable f (find-pushtype typename))) *push-functions*)) (defun most-current-type-for-function (function-name) "Returns the most current type for which the named function is applicable by consulting the type stack and the *typestack-bottom*. Returns the name of the implementation function as a second value." (do ((types (append (pushtype-stack (find-pushtype 'type)) *typestack-bottom*) (cdr types)) (type-result nil) (implementation nil)) ((or (null types) type-result) (unless type-result (error (format nil "No types on type stack that can be arguments for ~A." function-name))) (values type-result implementation)) (setq implementation (applicable function-name (find-pushtype (first types)))) (when implementation (setq type-result (find-pushtype (first types)))))) (defun most-current-concrete-type () "Returns the most current type by consulting the type stack and the *typestack-bottom*." (do ((types (append (pushtype-stack (find-pushtype 'type)) *typestack-bottom*) (cdr types)) (type-result nil)) ((or (null types) type-result) (unless type-result (error (format nil "No concrete types on type stack."))) type-result) (when (not (pushtype-abstract (find-pushtype (first types)))) (setq type-result (find-pushtype (first types)))))) (defun abort-push-if-limits-exceeded () "Aborts execution of the currently executing push program, via throw, if any enforced execution limits have been exceeded." (when (or (> *evalpush-count* *evalpush-limit*) (and *enforce-evalpush-time-limit* (> (elapsed-realtime-seconds) *evalpush-expiration-time*))) (throw :evalpush-limit-exceeded nil))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; interpreter (defun runpush (code &rest type-arg-pairs) "The top level of the push interpreter." ;; initializations (init-push-stacks) (setq *quote-destination* nil) (setq *evalpush-count* 0) (when *enforce-evalpush-time-limit* (setq *evalpush-expiration-time* (+ (elapsed-realtime-seconds) *evalpush-time-limit*))) ;; push the provided arguments onto the appropriate stacks (dolist (pair type-arg-pairs) (let ((type (find-pushtype (first pair)))) (push (second pair) (pushtype-stack type)))) ;; push the code (let ((code-type (find-pushtype 'code))) (push code (pushtype-stack code-type)) ;; begin execution, catching premature aborts (catch :evalpush-limit-exceeded (evalpush (first (pushtype-stack code-type)))))) (defun evalpush (tree) "Recursively evaluates tree, aborting prematurely if execution limits are exceeded." (incf *evalpush-count*) (abort-push-if-limits-exceeded) (cond (*quote-destination* ;; a lingering quote is handled here (setf (pushtype-stack *quote-destination*) (cons tree (pushtype-stack *quote-destination*))) (setq *quote-destination* nil)) (t ;; anything not quoted gets evaluated here (if (consp tree) (mapc #'evalpush tree) ;; recurse on lists (execute-instruction tree)))) (values)) ;; don't return anything (defun execute-instruction (instruction) "Executes a single push instruction." (cond ;; push literals ;; integer literal ((integerp instruction) (let ((type (find-pushtype 'integer))) (push instruction (pushtype-stack type)))) ;; float literal ((floatp instruction) (let ((type (find-pushtype 'float))) (push instruction (pushtype-stack type)))) ;; boolean literal ((or (eq instruction t) (eq instruction nil)) (let ((type (find-pushtype 'boolean))) (push instruction (pushtype-stack type)))) ;; type literal ((find-pushtype instruction) (let ((type (find-pushtype 'type))) (push instruction (pushtype-stack type)))) ;; anything else is either a function or a variable name ((not (member instruction *push-functions*)) (let ((type (find-pushtype 'name))) (push instruction (pushtype-stack type)))) ;; must be a function (t (when *track-calls* (track instruction)) (multiple-value-bind (type implementation) (most-current-type-for-function instruction) (funcall implementation type))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; stubs for pushpop interface (defun find-other (integer) "just a stub... if you want to use the provided &other you must provide code for this that is reasonable with respect to your population structure." (declare (ignore integer)) t) (defun find-elder (integer) "just a stub... if you want to use the provided &elder you must provide code for this that is reasonable with respect to your population structure." (declare (ignore integer)) t) (defun find-neighbor (integer) "just a stub... if you want to use the provided &neighbor you must provide code for this that is reasonable with respect to your population structure." (declare (ignore integer)) t) (defun find-other-tag (float) "just a stub... if you want to use the provided &other-tag you must provide code for this that is reasonable with respect to your population structure." (declare (ignore float)) t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; definitions for actual push types (defpushtype push-base-type () :abstract t :functions ((dup &dup) (pop &pop) (swap &swap) (rep &rep) (= &=) (noop &noop) ;; reason for this? (pull &pull) (pulldup &pulldup) (set &set) (get &get) (convert &convert) ;; acts on top two types on type stack )) (defpushtype number (push-base-type) :abstract t :functions ((+ &+) (- &-) (* &*) (/ &/) (< &<) (> &>) (min &min) (max &max)) ) (defpushtype integer (number) :abstract nil :default 0 :functions (;(rand &randint) (pull &pullint) (pulldup &pulldupint) (/ &/int))) (defpushtype float (number) :abstract nil :default 0 :functions (;(rand &randfloat) (sin &sin) (cos &cos) (tan &tan) )) (defpushtype boolean (push-base-type) :abstract nil :default nil :functions ((and &and) (or &or) (not ¬))) (defpushtype type (push-base-type) :abstract nil :default 'integer :functions nil) (defpushtype name (push-base-type) :abstract nil :default 'DEFAULT-NAME :functions (;(rand &randname) )) (defpushtype expression (push-base-type) :abstract t :functions ((quote "e) (atom &atom) (null &null) (car &car) (cdr &cdr) (cons &cons) (list &list) (append &append) (nth &nth) (nthcdr &nthcdr) (member &member) (position &position) ;; maybe add ;(rplaca &rplaca) ;(rplacd &rplacd) ;(rplanca &rplanca) ;(rplancd &rplancd) (subst &subst) ;(rand &randexp) (contains &contains) (container &container) ;(perturb &perturb) (replace-atoms &replace-atoms) ;(mix-atoms &mix-atoms) ;(other &other) ;(elder &elder) ;(neighbor &neighbor) ;(other-tag &other-tag) (insert &insert) (extract &extract) (instructions &instructions) (length &length) (size &size) (discrepancy &discrepancy) )) (defpushtype code (expression) :abstract nil :functions ((do &do) (do* &do*) (if &if) (map &map))) ;; The child type is just an expression stack, like code but without the ;; instructions that call the interpreter. It is intended for the production ;; of children in pushpop, an autoconstructive evolution system. #|(defpushtype child (expression) :abstract nil :functions ())|# ;; this is required after the last call to defpushtype (complete-push-configuration) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; method implementations for the instructions of defined types ;; The "&" in the method names is just a convention. (defun "e (type) "Specifies that the next expression submitted for interpretation will instead be pushed literally onto the stack of the given type." (setq *quote-destination* type)) (defun &dup (type) "Duplicates the top element of the stack of the given type." (unless (null (pushtype-stack type)) (push (copy-tree (first (pushtype-stack type))) (pushtype-stack type)))) (defun &pop (type) "Pops the stack of the given type." (unless (null (pushtype-stack type)) (setf (pushtype-stack type) (rest (pushtype-stack type))))) (defun &swap (type) "Swaps the top two elements of the stack of the given type." (unless (null (rest (pushtype-stack type))) (setf (pushtype-stack type) (cons (second (pushtype-stack type)) (cons (first (pushtype-stack type)) (rest (rest (pushtype-stack type)))))))) (defun &rep (type) "Deletes the second item of the stack of the given type. So called because in some contexts it is natural to think of this as REPlacing the second element with the first." (unless (null (rest (pushtype-stack type))) (setf (pushtype-stack type) (cons (first (pushtype-stack type)) (rest (rest (pushtype-stack type))))))) (defun &convert (type) "Pushes onto the stack of the most current concrete type a value converted from the item on top of the stack of the second most current concrete type (as determined from the type stack plus the type stack bottom." ;; all conversions are concrete type to concrete type ;; concrete types for this version are: ;; integer, float, boolean, type, name, code, child (declare (ignore type)) ;; we'll find the types ourselves (let* ((concrete-types (remove-if #'(lambda (name) (pushtype-abstract (find-pushtype name))) (append (pushtype-stack (find-pushtype 'type)) *typestack-bottom*))) (to-type (find-pushtype (first concrete-types))) (from-type (find-pushtype (second concrete-types)))) (unless (null (pushtype-stack from-type)) (let ((value-to-convert (first (pushtype-stack from-type)))) (push (case (pushtype-name to-type) (integer (case (pushtype-name from-type) (integer value-to-convert) (float (truncate value-to-convert)) (boolean (if value-to-convert 1 0)) (type (position from-type *pushtypes*)) (name 0) (code (safe-length value-to-convert)) (child (safe-length value-to-convert)))) (float (* 1.0L0 (case (pushtype-name from-type) (integer value-to-convert) (float value-to-convert) (boolean (if value-to-convert 1.0 0.0)) (type (float (position from-type *pushtypes*))) (name 0.0) (code (safe-length value-to-convert)) (child (safe-length value-to-convert))))) (boolean (case (pushtype-name from-type) (integer (not (zerop value-to-convert))) (float (not (zerop value-to-convert))) (boolean value-to-convert) (type nil) (name nil) (code (null value-to-convert)) (child (null value-to-convert)))) (type (case (pushtype-name from-type) (integer 'integer) (float 'float) (boolean 'boolean) (type 'type) (name 'name) (code 'code) (child 'child))) (name (case (pushtype-name from-type) (integer 'integer) (float 'float) (boolean 'boolean) (type 'type) (name 'name) (code 'code) (child 'child))) (code (copy-tree value-to-convert)) (child (copy-tree value-to-convert))) (pushtype-stack to-type))) ;; pop the source stack (pop (pushtype-stack from-type))))) (defun &set (type) "Stores a binding of the given type, binding the name on the top of the name stack to the item on top of the stack of the given type." (let ((name-type (find-pushtype 'name))) (unless (or (null (pushtype-stack type)) (null (pushtype-stack name-type))) (setf (pushtype-bindings type) (acons (first (pushtype-stack name-type)) (first (pushtype-stack type)) (pushtype-bindings type))) (pop (pushtype-stack type)) (pop (pushtype-stack name-type))))) (defun &get (type) "Pushes the binding of the given type for the name on top of the name stack onto the stack of the given type. If there is no such binding then pushes the default value for the given type." (let ((name-type (find-pushtype 'name))) (unless (null (pushtype-stack name-type)) (push (copy-tree (or (cdr (assoc (first (pushtype-stack name-type)) (pushtype-bindings type))) (pushtype-default type))) (pushtype-stack type)) (pop (pushtype-stack name-type))))) (defun &pull (type) ;; not for ints "Pulls an item from an indexed position within the stack of the given type and pushes it on top of the stack. This version is not for use with the integer type (which requires special handling because of the integer index argument." (let ((int (find-pushtype 'integer)) (stack-size (length (pushtype-stack type)))) (unless (or (null (pushtype-stack int)) (< stack-size 2)) (let ((pull-index (mod (first (pushtype-stack int)) stack-size))) (setf (pushtype-stack int) (rest (pushtype-stack int))) (setf (pushtype-stack type) (cons (nth pull-index (pushtype-stack type)) (append (subseq (pushtype-stack type) 0 pull-index) (subseq (pushtype-stack type) (1+ pull-index))))))))) (defun &pulldup (type) ;; not for ints "Duplicates an item from an indexed position within the stack of the given type and pushes it on top of the stack. This version is not for use with the integer type (which requires special handling because of the integer index argument." (let ((int (find-pushtype 'integer)) (stack-size (length (pushtype-stack type)))) (unless (or (null (pushtype-stack int)) (< stack-size 1)) (let ((pull-index (mod (first (pushtype-stack int)) stack-size))) (setf (pushtype-stack int) (rest (pushtype-stack int))) (setf (pushtype-stack type) (cons (copy-tree (nth pull-index (pushtype-stack type))) (pushtype-stack type))))))) (defun &pullint (type) "A version of &pull specialized for integers." (let* ((int type) (int-stack-size (length (pushtype-stack int)))) (unless (< int-stack-size 2) (let ((pull-index (mod (first (pushtype-stack int)) (1- int-stack-size)))) ;; chop off the index (setf (pushtype-stack int) (rest (pushtype-stack int))) ;; pull out the indexed element (setf (pushtype-stack int) (cons (nth pull-index (pushtype-stack int)) (append (subseq (pushtype-stack int) 0 pull-index) (subseq (pushtype-stack int) (1+ pull-index))))))))) (defun &pulldupint (type) "A version of &pulldup specialized for integers." (let* ((int type) (int-stack-size (length (pushtype-stack int)))) (unless (< int-stack-size 2) (let ((pull-index (mod (first (pushtype-stack int)) (1- int-stack-size)))) ;; chop off the index (setf (pushtype-stack int) (rest (pushtype-stack int))) ;; dup the indexed element (setf (pushtype-stack int) (cons (copy-tree (nth pull-index (pushtype-stack int))) (pushtype-stack int))))))) (defun &= (type) "Pushes T onto the boolean stack if the top two elements of the stack of the given type are equalp." (let ((stack-contents (pushtype-stack type)) (boolean-type (find-pushtype 'boolean))) (unless (null (rest stack-contents)) (let ((answer (equalp (second stack-contents) (first stack-contents)))) (setf (pushtype-stack type) (rest (rest stack-contents))) (push answer (pushtype-stack boolean-type)))))) (defun &+ (type) "Adds the top two elements of the stack of the given type and pushes the result." (let ((stack-contents (pushtype-stack type))) (unless (null (rest stack-contents)) (setf (pushtype-stack type) (cons (keep-number-reasonable (+ (second stack-contents) (first stack-contents))) (rest (rest stack-contents))))))) (defun &- (type) "Subtracts the top two elements of the stack of the given type and pushes the result." (let ((stack-contents (pushtype-stack type))) (unless (null (rest stack-contents)) (setf (pushtype-stack type) (cons (keep-number-reasonable (- (second stack-contents) (first stack-contents))) (rest (rest stack-contents))))))) (defun &* (type) "Multiplies the top two elements of the stack of the given type and pushes the result." (let ((stack-contents (pushtype-stack type))) (unless (null (rest stack-contents)) (setf (pushtype-stack type) (cons (keep-number-reasonable (* (second stack-contents) (first stack-contents))) (rest (rest stack-contents))))))) (defun &/ (type) "Divides the top two elements of the stack of the given type and pushes the result. Division by zero produces zero." (let ((stack-contents (pushtype-stack type))) (unless (null (rest stack-contents)) (setf (pushtype-stack type) (cons (if (zerop (first stack-contents)) 0.0 (keep-number-reasonable (/ (second stack-contents) (first stack-contents)))) (rest (rest stack-contents))))))) (defun &/int (type) "A division instruction specialized for integers; always produced an integer result (via truncation)." (let ((stack-contents (pushtype-stack type))) (unless (null (rest stack-contents)) (setf (pushtype-stack type) (cons (if (zerop (first stack-contents)) 0 (keep-number-reasonable (truncate (/ (second stack-contents) (first stack-contents))))) (rest (rest stack-contents))))))) (defun &min (type) "Pushes the smaller of the top two elements of the given type." (let ((stack-contents (pushtype-stack type))) (unless (null (rest stack-contents)) (setf (pushtype-stack type) (cons (min (second stack-contents) (first stack-contents)) (rest (rest stack-contents))))))) (defun &max (type) "Pushes the larger of the top two elements of the given type." (let ((stack-contents (pushtype-stack type))) (unless (null (rest stack-contents)) (setf (pushtype-stack type) (cons (max (second stack-contents) (first stack-contents)) (rest (rest stack-contents))))))) (defun &sin (type) "Pushes the sin of the top element of the stack of the given type." (let ((stack-contents (pushtype-stack type))) (unless (null stack-contents) (setf (pushtype-stack type) (cons (keep-number-reasonable (sin (first stack-contents))) (rest stack-contents)))))) (defun &cos (type) "Pushes the cosine of the top element of the stack of the given type." (let ((stack-contents (pushtype-stack type))) (unless (null stack-contents) (setf (pushtype-stack type) (cons (keep-number-reasonable (cos (first stack-contents))) (rest stack-contents)))))) (defun &tan (type) "Pushes the tangent of the top element of the stack of the given type." (let ((stack-contents (pushtype-stack type))) (unless (null stack-contents) (setf (pushtype-stack type) (cons (keep-number-reasonable (tan (first stack-contents))) (rest stack-contents)))))) (defun &< (type) "Pushes T onto the boolean stack if the second element of the stack of the given type is less than the first element." (let ((stack-contents (pushtype-stack type)) (boolean-type (find-pushtype 'boolean))) (unless (null (rest stack-contents)) (push (< (second stack-contents) (first stack-contents)) (pushtype-stack boolean-type)) (setf (pushtype-stack type) (rest (rest stack-contents)))))) (defun &> (type) "Pushes T onto the boolean stack if the second element of the stack of the given type is greater than the first element." (let ((stack-contents (pushtype-stack type)) (boolean-type (find-pushtype 'boolean))) (unless (null (rest stack-contents)) (push (> (second stack-contents) (first stack-contents)) (pushtype-stack boolean-type)) (setf (pushtype-stack type) (rest (rest stack-contents)))))) (defun &and (type) "Pushes the result of a boolean AND of the top two elements of the given type." (let ((stack-contents (pushtype-stack type))) (unless (null (rest stack-contents)) (setf (pushtype-stack type) (cons (and (second stack-contents) (first stack-contents)) (rest (rest stack-contents))))))) (defun &or (type) "Pushes the result of a boolean OR of the top two elements of the given type." (let ((stack-contents (pushtype-stack type))) (unless (null (rest stack-contents)) (setf (pushtype-stack type) (cons (or (second stack-contents) (first stack-contents)) (rest (rest stack-contents))))))) (defun ¬ (type) "Pushes the result of a boolean NOT of the top element of the given type." (let ((stack-contents (pushtype-stack type))) (unless (null stack-contents) (setf (pushtype-stack type) (cons (not (first stack-contents)) (rest stack-contents)))))) (defun &do (type) "Recursively invokes the interpreter on the expression on top of the given stack. After evaluation the stack is popped; normally this pops the expression that was just evaluated, but if the expression itself manipulates the stack then this final pop may end up popping something else." (unless (null (pushtype-stack type)) (evalpush (copy-tree (first (pushtype-stack type)))) (pop (pushtype-stack type)))) (defun &do* (type) "Like &do but pops the expression before evaluating it." (unless (null (pushtype-stack type)) (let ((to-do (first (pushtype-stack type)))) (pop (pushtype-stack type)) (evalpush to-do)))) (defun &map (type) "Treats the item on top of the stack of the given type as a list (coercing it to a list if necessary) and the second element as a body of code to apply iteratively to each element of the list. The arguments are both popped prior to the recursive evaluations. The results are collected and pushed as a list." (unless (null (rest (pushtype-stack type))) (let ((the-list (ensure-list (first (pushtype-stack type)))) (the-code (second (pushtype-stack type)))) ;; clear the args (pop (pushtype-stack type)) (pop (pushtype-stack type)) ;; do the mapping (let ((results nil)) (dolist (item the-list) (push item (pushtype-stack type)) (evalpush the-code) ;; extract, save, and remove the result (push (first (pushtype-stack type)) results) (pop (pushtype-stack type)) (when (> (count-points results) ;; escape if result is bloating *max-points-in-program*) (return nil))) (unless (> (count-points results) *max-points-in-program*) (push (reverse (copy-tree results)) (pushtype-stack type))))))) (defun &if (type) "If the top element of the boolean stack is true this recursively evaluates the second element of the code stack; otherwise it recursively evaluates the first element of the code stack. Either way both elemets of the code stack (and the boolean value upon which the decision was made) are popped." (let ((boolean-type (find-pushtype 'boolean))) (unless (or (null (pushtype-stack boolean-type)) (null (rest (pushtype-stack type)))) (let ((to-do (if (first (pushtype-stack boolean-type)) (second (pushtype-stack type)) (first (pushtype-stack type))))) ;; remove all of the arguments (pop (pushtype-stack type)) (pop (pushtype-stack type)) (pop (pushtype-stack boolean-type)) ;; do the specified code (evalpush to-do) )))) (defun &noop (type) "Does nothing." (declare (ignore type)) nil) (defun &car (type) "Pushes the car of the top element of the stack of the given type (which is coerced to a list if necessary)." (let ((stack (pushtype-stack type))) (unless (null stack) (let ((new-item (car (ensure-list (first stack))))) (setf (pushtype-stack type) (cons new-item (rest stack))))))) (defun &cdr (type) "Pushes the cdr of the top element of the stack of the given type (which is coerced to a list if necessary)." (let ((stack (pushtype-stack type))) (unless (null stack) (let ((new-item (cdr (ensure-list (first stack))))) (setf (pushtype-stack type) (cons new-item (rest stack))))))) (defun &cons (type) "Pushes the result of consing the second element of the stack of the given type onto the first element (which is coerced to a list if necessary)." (let ((stack (pushtype-stack type))) (unless (null (rest stack)) (let* ((new-car (second stack)) (new-cdr (first stack)) (new-item (cons new-car (ensure-list new-cdr)))) (unless (> (count-points new-item) *Max-Points-In-Program*) (setf (pushtype-stack type) (cons new-item (rest (rest stack))))))))) (defun &list (type) "Pushes a list of the top two elements of the stack of the given type." (let ((stack (pushtype-stack type))) (unless (or (null (rest stack)) (> (+ (count-points (first stack)) (count-points (second stack)) 1) *max-points-in-program*)) (setf (pushtype-stack type) (cons (list (second stack) (first stack)) (rest (rest stack))))))) (defun &append (type) "Pushes the result of appending the top two elements of the stack of the given type, coercing them to lists if necessary." (let ((stack (pushtype-stack type))) (unless (null (rest stack)) (let ((new-item (append (ensure-list (second stack)) (ensure-list (first stack))))) (unless (> (count-points new-item) *Max-Points-In-Program*) (setf (pushtype-stack type) (cons new-item (rest (rest stack))))))))) (defun &nth (type) "Pushes the nth element of the expression on top of the stack of the given type onto that stack (after popping the expression from which it was taken). The expression is coerced to a list if necessary. If the expression is NIL then the result is NIL. N is taken from the integer stack (which is popped) and is taken modulo the length of the expression into which it is indexing." (let ((int (find-pushtype 'integer)) (stack (pushtype-stack type))) (unless (or (null stack) (null (pushtype-stack int))) (let* ((the-list (ensure-list (first stack))) (new-item (if (null the-list) nil (nth (mod (first (pushtype-stack int)) (length the-list)) the-list)))) (setf (pushtype-stack type) (cons new-item (rest stack))) (pop (pushtype-stack int)))))) (defun &nthcdr (type) "Pushes the nth cdr of the expression on top of the stack of the given type onto that stack (after popping the expression from which it was taken). The expression is coerced to a list if necessary. If the expression is NIL then the result is NIL. N is taken from the integer stack (which is popped) and is taken modulo the length of the expression into which it is indexing." (let ((int (find-pushtype 'integer)) (stack (pushtype-stack type))) (unless (or (null stack) (null (pushtype-stack int))) (let* ((the-list (ensure-list (first stack))) (new-item (if (null the-list) nil (nthcdr (mod (first (pushtype-stack int)) (length the-list)) the-list)))) (setf (pushtype-stack type) (cons new-item (rest stack))) (pop (pushtype-stack int)))))) (defun &member (type) "Pushes t onto the boolean stack if the second element of the stack of the given type is a member of the first element (which is coerced to a list if necessary). The result is just a boolean value (not the matching tail as with Common Lisp's MEMBER. Comparisons are made with equalp." (let ((stack (pushtype-stack type)) (bool (find-pushtype 'boolean))) (unless (null (rest stack)) (push (if (member (second stack) (ensure-list (first stack)) :test #'equalp) t nil) (pushtype-stack bool)) (pop (pushtype-stack type)) (pop (pushtype-stack type))))) (defun &position (type) "Pushes onto the integer stack the position of the second element of the stack of the given type within the first element (which is coerced to a list if necessary. Comparisons are made with equalp. Pushes -1 if no match is found." (let ((stack (pushtype-stack type)) (int (find-pushtype 'integer))) (unless (null (rest stack)) (push (or (position (second stack) (ensure-list (first stack)) :test #'equalp) -1) (pushtype-stack int)) (pop (pushtype-stack type)) (pop (pushtype-stack type))))) (defun &length (type) "Pushes the length of the first element of the stack of the given type onto the integer stack, coercing it to a list first if necessary." (let ((stack (pushtype-stack type)) (int (find-pushtype 'integer))) (unless (null stack) (push (length (ensure-list (first stack))) (pushtype-stack int)) (pop (pushtype-stack type))))) (defun &size (type) "Pushes the number of points in the first element of the stack of the given type onto the integer stack, coercing it to a list first if necessary." (let ((stack (pushtype-stack type)) (int (find-pushtype 'integer))) (unless (null stack) (push (count-points (ensure-list (first stack))) (pushtype-stack int)) (pop (pushtype-stack type))))) (defun &discrepancy (type) "Pushes onto the integer stack the discrepancy between the first element of the stack of the given type and the second element of the stack of the given type." (let ((stack (pushtype-stack type)) (int (find-pushtype 'integer))) (unless (null (rest stack)) (push (discrepancy (first stack) (second stack)) (pushtype-stack int)) (pop (pushtype-stack type)) (pop (pushtype-stack type))))) (defun &insert (type) "Pushes the result of inserting the second element of the stack of the given type into the first element. The index of the insertion point is taken from the integer stack, modulo the length of the expression into which the insertion is being made. Pops all arguments." (let ((int (find-pushtype 'integer)) (stack (pushtype-stack type))) (unless (or (null (rest stack)) (null (pushtype-stack int))) (let ((new-code (insert-code-at-point (copy-tree (second stack)) (first (pushtype-stack int)) (copy-tree (first stack))))) (unless (> (count-points new-code) *Max-Points-In-Program*) (setf (pushtype-stack type) (cons new-code (rest (rest stack)))) (pop (pushtype-stack int))))))) (defun &extract (type) "Pushes the subexpression of the top element of the stack of the given type that is indexed by the integer on top of the integer stack." (let ((int (find-pushtype 'integer)) (stack (pushtype-stack type))) (unless (or (null stack) (null (pushtype-stack int))) (let ((new-code (code-at-point (first stack) (first (pushtype-stack int))))) (setf (pushtype-stack type) (cons (copy-tree new-code) (rest stack))) (pop (pushtype-stack int)))))) (defun &instructions (type) "Pushes a list of the instructions that are implemented for the type on top of the type stack onto the stack of the given type." (let ((for-which-type (first (append (pushtype-stack (find-pushtype 'type)) *typestack-bottom*)))) (setf (pushtype-stack type) (cons (instructions-for-type for-which-type) (pushtype-stack type))))) (defun &container (type) "Pushes onto the stack of the given type the result of calling containing-subtree on the first and second elements of that stack." (let ((stack (pushtype-stack type))) (unless (null (rest stack)) (let ((new-code (containing-subtree (first stack) (second stack)))) (setf (pushtype-stack type) (cons (copy-tree new-code) (rest (rest stack)))))))) (defun &atom (type) "Pushes T on the boolean stack if the top element of the stack of the given type is an atom; pushes NIL otherwise." (let ((stack (pushtype-stack type)) (bool (find-pushtype 'boolean))) (unless (null stack) (setf (pushtype-stack bool) (cons (atom (first stack)) (pushtype-stack bool)))) (pop (pushtype-stack type)))) (defun &null (type) "Pushes T on the boolean stack if the top element of the stack of the given type is NIL; pushes NIL otherwise." (let ((stack (pushtype-stack type)) (bool (find-pushtype 'boolean))) (unless (null stack) (setf (pushtype-stack bool) (cons (null (first stack)) (pushtype-stack bool)))) (pop (pushtype-stack type)))) (defun &subst (type) "Pushes the result of substituting the third element of the stack of the given type for the second item in the first item. All three of the arguments are popped. Comparisons for the substitution use equalp. There are several problematic possibilities; for example dotted-lists could result. If any of these problematic possibilities occurs the stack is left unchanged." (let ((stack (pushtype-stack type))) (unless (null (rest (rest (rest stack)))) (let ((tree (copy-tree (first stack))) (old (copy-tree (second stack))) (new (copy-tree (third stack)))) (unless (or (null old) ;; get dotted lists with null old (and (listp old) (member new old :test #'equalp)) (and (listp new) (member old new :test #'equalp))) ;; can also get dotted lists from subst in other ways, eg: ;; (subst 'x '(foo) '(bar (biz foo)) :test #'equalp) ;; so check and leave things alone if dotted (let ((subst-result (subst new old tree :test #'equalp))) (unless (or (improper subst-result) (> (count-points subst-result) *max-points-in-program*)) ;(format t "~%~%~A~%~%" subst-result) (setf (pushtype-stack type) (cons (copy-tree subst-result) ;should eliminate shared internal structure (rest (rest (rest stack)))))))))))) (defun &contains (type) "Pushes T on the boolean stack if the first item on the stack of the given type contains the second item." (let ((stack (pushtype-stack type)) (bool (find-pushtype 'boolean))) (unless (null (rest stack)) (push (contains-subtree (first stack) (second stack)) (pushtype-stack bool))) (pop (pushtype-stack type)))) (defun &perturb (type) "Pushes a stochastically perturbed copy of the top item of the stack of the given type (after popping this item). Perturbation will only replace atoms with other atoms. The degree of perturbation is controlled by an integer which is popped from the integer stack." (let ((stack (pushtype-stack type)) (int (find-pushtype 'integer))) (unless (or (null stack) (null (pushtype-stack int))) (let ((i (first (pushtype-stack int)))) (setf (pushtype-stack type) (cons (dirty-copy (first stack) (if (zerop i) :infinite i)) (rest (pushtype-stack type))))) (pop (pushtype-stack int))))) (defun &replace-atoms (type) "Pushes a copy of the top of item of the given type with a version in which the atoms have been replaced with the atoms from the second item. Both of the used arguments are popped." (let ((stack (pushtype-stack type))) (unless (null (rest stack)) (setf (pushtype-stack type) (cons (with-atoms (first stack) (flatten (second stack))) (rest (rest (pushtype-stack type)))))))) (defun &mix-atoms (type) "Pushes a copy of the top of item of the given type with a version in which the atoms have been replaced with the atoms from the first and second items (using a 'uniform crossover'-like approach). Both of the used arguments are popped." (let ((stack (pushtype-stack type))) (unless (null (rest stack)) (setf (pushtype-stack type) (cons (with-atoms-uniform-crossover (first stack) (flatten (first stack)) (flatten (second stack))) (rest (rest (pushtype-stack type)))))))) (defun &other (type) "Pushes the code of another program in the population. This only makes sense when there is in fact a population, as in pushpop. The target program is found via FIND-OTHER which requires an integer argument; the argument is popped from the integer stack." (let ((stack (pushtype-stack type)) (int (find-pushtype 'integer))) (unless (null (pushtype-stack int)) (setf (pushtype-stack type) (cons (copy-tree (find-other (first (pushtype-stack int)))) (rest stack))) (pop (pushtype-stack int))))) (defun &elder (type) "Pushes the code of another program in the population. This only makes sense when there is in fact a population, as in pushpop. The target program is found via FIND-ELDER which requires an integer argument; the argument is popped from the integer stack." (let ((stack (pushtype-stack type)) (int (find-pushtype 'integer))) (unless (null (pushtype-stack int)) (setf (pushtype-stack type) (cons (copy-tree (find-elder (first (pushtype-stack int)))) (rest stack))) (pop (pushtype-stack int))))) (defun &neighbor (type) "Pushes the code of another program in the population. This only makes sense when there is in fact a population, as in pushpop. The target program is found via FIND-NEIGHBOR which requires an integer argument; the argument is popped from the integer stack." (let ((stack (pushtype-stack type)) (int (find-pushtype 'integer))) (unless (null (pushtype-stack int)) (setf (pushtype-stack type) (cons (copy-tree (find-neighbor (first (pushtype-stack int)))) (rest stack))) (pop (pushtype-stack int))))) (defun &other-tag (type) ;; tags are floats "Pushes the code of another program in the population. This only makes sense when there is in fact a population, as in pushpop. The target program is found via FIND-OTHER-TAG which requires a floating point argument; the argument is popped from the float stack." (let ((stack (pushtype-stack type)) (float (find-pushtype 'float))) (unless (null (pushtype-stack float)) (setf (pushtype-stack type) (cons (copy-tree (find-other-tag (first (pushtype-stack float)))) (rest stack))) (pop (pushtype-stack float))))) (defun &randname (type) "A version of rand specialized for the name type. Pushes a new random name. This may or may not be pushed on *push-names* and thereby be available for inclusion in code randomly generated in the future -- depending on what has been commented-out in the definition." (let ((new-symbol (gentemp "PUSH-VAR-"))) (push new-symbol (pushtype-stack type)) ;(push new-symbol *push-names*) ;; in some applications this makes *push-names* way too huge )) (defun &randint (type) "A version of rand specialized for integers. Pushes a random integer onto the integer stack." (push (randint *random-int-limit*) (pushtype-stack type))) (defun &randfloat (type) "A version of rand specialized for floating point numbers. Pushes a random floating point number onto the float stack." (push (randfloat *random-float-limit*) (pushtype-stack type))) (defun &randexp (type) "A version of rand specialized for expressions. Pushes a random expression onto the stack of the given type. An integer argument is used to limit the size of the expression (and is then popped)." (let ((stack (pushtype-stack type)) (int (find-pushtype 'integer))) (unless (null (pushtype-stack int)) (setf (pushtype-stack type) (cons (random-code (abs (mod (first (pushtype-stack int)) *max-points-in-random-expressions*))) stack)) (pop (pushtype-stack int))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; examples #| ;; 5-2 (runpush '(5 2 -)) (print-stacks) ;; in a more complex way (runpush '(code quote (5 2 -) do)) (print-stacks) ;; input + itself (runpush '(dup +) '(integer 5)) (print-stacks) ;; in a more complex way (runpush '(code quote (integer dup +) do) '(integer 5)) (print-stacks) ;; factorial via stack manipulation (runpush '(code quote (quote (1 rep) quote (code dup integer dup 1 - do *) integer dup 2 < if) do) '(integer 5)) (print-stacks) ;; a simpler factorial (thanks to Alan Robinson) (runpush '(quote (pop 1) quote (code dup integer dup 1 - do *) integer dup 2 < if) '(integer 5)) (print-stacks) ;; factorial with a named subroutine (runpush '(code factorial quote (code quote (pop 1) quote (dup 1 - code factorial get do *) integer dup 2 < if) dup set do) '(integer 5)) (print-stacks) ;; another named factorial, perhaps the nicest stylistically (runpush '(code quote (quote (pop 1) quote (integer dup 1 - code factorial get do *) integer dup 2 < if) factorial set factorial get do) '(integer 5)) (print-stacks) ;; factorial with a named subroutine and args passed via a single variable ;; also careful not to pass the code by stack ever (runpush '(code factorial quote (integer arg get code quote (pop 1) quote (dup 1 - code factorial get integer arg set do *) integer dup 2 < if) set pop integer arg set code factorial get do) '(integer 5)) (print-stacks) ;; as above but with localized variables for arguments, very messy (runpush '(code factorial quote (integer arg get code quote (pop 1) quote (dup 1 - new-variable name dup integer set name code convert code quote arg code factorial get subst code factorial set factorial get do *) integer dup 2 < if) set integer arg set code factorial get do) '(integer 5)) (print-stacks) ;; mutating version (mutant left on code stack) (runpush '(code quote (quote (1 rep) quote (code dup integer dup 1 - do *) integer dup 2 < if) do integer rand rand code rand insert ) '(integer 5)) (print-stacks) ;; float version (runpush '(code quote (quote (1.0 rep) quote (code dup float dup 1.0 - do *) float dup 2.0 < if) do) '(float 5.0)) (print-stacks) ;; boolean tests (runpush '(nil t or nil not and)) (print-stacks) (runpush '(nil t and nil not and)) (print-stacks) (runpush '(nil t or t not and)) (print-stacks) ;; atom (runpush '(code quote foo atom)) (print-stacks) (runpush '(code quote (foo bar) atom)) (print-stacks) ;; null (runpush '(code quote foo null)) (print-stacks) (runpush '(code quote nil null)) (print-stacks) ;; car (runpush '(code quote (foo bar baz) car)) (print-stacks) ;; cdr (runpush '(code quote (foo bar baz) cdr)) (print-stacks) ;; cons (runpush '(code quote bonk quote (foo bar baz) cons)) (print-stacks) (runpush '(code quote bonk quote foo cons)) ;; cons onto atom (print-stacks) ;; list (runpush '(code quote foo quote bar list)) (print-stacks) ;; append (runpush '(code quote (foo) quote (bar) append)) (print-stacks) (runpush '(code quote foo quote bar append)) (print-stacks) ;; nth (runpush '(code quote (a b c d) 2 nth)) (print-stacks) (runpush '(code quote (a b c d) 2000 nth)) (print-stacks) ;; nthcdr (runpush '(code quote (a b c d) 2 nthcdr)) (print-stacks) (runpush '(code quote (a b c d) 2000 nthcdr)) (print-stacks) ;; member (runpush '(code quote (a b) quote (x (a b) y) member)) (print-stacks) (runpush '(code quote (a b) quote (x (a x) y) member)) (print-stacks) ;; position (runpush '(code quote (a b) quote (x (a b) y) position)) (print-stacks) (runpush '(code quote (a b) quote (x (a x) y) position)) (print-stacks) ;; subst (runpush '(code quote (foo) quote (bar) quote (bing (bar) biz ((bar))) subst)) (print-stacks) ;; contains (runpush '(code quote (a) quote (x (b (a))) contains)) (print-stacks) (runpush '(code quote (a) quote (x (b (z))) contains)) (print-stacks) ;; container (runpush '(code quote (a) quote (x (b (a))) container)) (print-stacks) (runpush '(code quote (a) quote (x (b (z))) container)) (print-stacks) ;; pulldup (runpush '(0.0 13 float pulldup)) (print-stacks) (runpush '(0.0 1.0 2.0 1 float pulldup)) (print-stacks) (runpush '(10 11 12 1 integer pulldup)) (print-stacks) |#