;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; push2.lisp ;; a programming language for evolutionary computation ;; c) 2000-2003, Lee Spector (lspector@hampshire.edu) ;; ;; distribution location: http://hampshire.edu/lspector/push.html #| Push is a programming language intended for primarily for use in evolutionary computation systems (such as genetic programming systems), as the language in which evolving programs are expressed. The code in this file implements version 2 of Push, a.k.a Push2, in Common Lisp. For more information about Push in general and and Push2 in particular please see: http://hampshire.edu/lspector/push2-description.html Although it is based on Push1, the best introduction to the basic principles of Push and its use for evolutionary computation is still: Spector, L., and A. Robinson. 2002. Genetic Programming and Autoconstructive Evolution with the Push Programming Language. In Genetic Programming and Evolvable Machines, Vol. 3, No. 1, pp. 7-40. http://hampshire.edu/lspector/pubs/push-gpem-final.pdf NOTES SPECIFIC TO THIS IMPLEMENTATION ------------------------------------- Generate a full configuration file with generate-full-config-file, which takes a path as its single argument. In MCL you can use: (generate-full-config-file (choose-new-file-dialog)) Configure the interpreter with configure-push-from-file, which takes a path as its single argument. In MCL you can use: (configure-push-from-file (choose-file-dialog)) If you are defining additional types or instructions, do so after loading this file and then call (complete-push-pre-configuration) again. You should configure from a file AFTER doing this. The Push2 test suite mechanism is invoked via the push-test function, which takes no arguments and has the following documentation: Reads three files from the given directory: push.pconf, push.program, and push.input, and produces the file push.output in the same directory. The input file should contain a list of literals that will be used to initialize the stacks. The output file will contain a list of literals which, if read back in, would re-create the stacks at the end of the computation. The values in the output file are listed type by type, following the order in which types are declared in the configuration (pconf) file. To compare two push.output files you may want to use the diff function, which takes two paths and compares the contents of the files at those paths. The file contents are read using the Lisp reader, so spaces and line breaks between items will not be considered significant. This implementation does not require space around parentheses in program or data inputs, but other Push2 implementations may. Most code in this implementation works with and will produce parentheses without surrounding spaces, but a function called spacey-parentheses can be used to produce output with spaces on both sides of each parenthesis. Push-test uses this function to ensure cross-implementation compatibility. Use the defpushtype macro to define new Push types, and the deftemplate macro to implement new Push instructions. See the types and instructions defined below for details. VERSION HISTORY --------------- INITIAL PUSH2 VERSION: adapted from the 20030413 push/pushgp distribution. A few implementation-specific changes from push1, aside from those documented in push2-description.html: No instruction name/implementation distinction. Ercs in types. RUNPUSH takes list of values rather than type/val pairs 20031116: Changed consp to listp in EVALPUSH, completing transition from t/nil to true/false. 20031130: Added defaults for all types (for GET). Changed arg order for CONTAINS. 20031202: Fixed NOOP conditions for SHOVE. 20031205: Fixed NOOP conditions for YANK and YANKDUP. 20031206: Fixed SET and GET for special cases with NAME.SET and NAME.GET. Added pushparamters for random number limits. 20031229: Minor changes for openmcl. Added support for constant instructions defined in config files, including SETCONSTANT for setting them. Added RANDOM-SEED push parameter, which can occur in config files. 20031230: Changed config file extension to .pconf (instead of .pst). 20040111: Fixed off-by-1 error in random-code handling of max-points. 20040112: Changed *./ and *.% (divide and mod templates) to NOOP instead of pushing zero when denominator is zero. Changed *.GET to NOOP instead of pushing default values for unbound names. |# ;; possible optimization declarations ;(declaim (optimize (speed 3) (safety 1) (space 0) (debug 0))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; parameters (defparameter *push-parameters* nil "The names of all push parameters.") (defmacro defpushparameter (name value &optional (documentation "")) `(progn (push ',(list name value documentation) *push-parameters*) (defparameter ,name ,value ,documentation))) ;;; defined pushparameters (defpushparameter *max-points-in-program* 100 "The maximum number of points that can occur in any program on the CODE stack. Instructions that would violate this limit act as NOOPs (they do nothing).") (defpushparameter *max-points-in-random-expressions* 50 "The maximum number of points in an expression produced by the CODE.RAND instruction.") (defpushparameter *new-erc-name-probability* 0.001 "The probability that the selection of the ephemeral random name constant will produce and return a new name.") (defpushparameter *evalpush-limit* 150 "The maximum number of points that will be executed in a single top-level call to runpush.") (defpushparameter *MIN-RANDOM-INTEGER* -10 "The minimum INTEGER that will be produced as an ephemeral random INTEGER constant or from a call to INTEGER.RAND.") (defpushparameter *MAX-RANDOM-INTEGER* 10 "The maximum INTEGER that will be produced as an ephemeral random INTEGER constant or from a call to INTEGER.RAND.") (defpushparameter *MIN-RANDOM-FLOAT* -1.0 "The minimum FLOAT that will be produced as an ephemeral random FLOAT constant or from a call to FLOAT.RAND.") (defpushparameter *MAX-RANDOM-FLOAT* 1.0 "The maximum FLOAT that will be produced as an ephemeral random FLOAT constant or from a call to FLOAT.RAND.") (defpushparameter *RANDOM-SEED* 0 "An integer, 0 <= n <= 30081, which is used to seed the random number generator.") ;; regular parameters (not defined as pushparameters) (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 the NAME.RAND instruction. If you allow this augmentation you should think about when you want to re-initialize this.") (defparameter *track-calls* nil "Determines whether or not the instruction-call-tracking system will track instruction calls.") (defparameter *max-positive-integer* 100000000000000000000 "The limit for 'reasonableness' of integers as enforced by the keep-number-reasonable function.") (defparameter *close-enough-to-zero* (/ 1 *max-positive-integer*) "Numbers closer to zero than this are converted to zero by the keep-number-reasonable function.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; global variables (defparameter *instruction-set* nil "The set of all valid push instructions.") (defparameter *evalpush-count* 0 "Tracks the number of point evaluations in the current call to runpush.") (defparameter *evalpush-expiration-time* 0 "Stores the cutoff time for runpush time limits if they are being enforced.") (defparameter *pushtypes* nil "All types in the current push type hierarchy. Augmented by defpushtype and reset by initialize-pushtype-system.") (defparameter *pushtype-hashtable* (make-hash-table) "Stores the pushtype data structures for faster access.") (defparameter *push-instructions* nil "A list of all instructions that have implemented methods for the current pushtypes. This is a subset of the *instruction-set*.") (defparameter *quote-destination* nil "Stores the type to which the next evaluated expression will be quoted. This will be nil when no quote is pending.") (defparameter *ephemeral-random-constant-generators* nil "A list of all ephemeral random constant names.") (defparameter *templates* nil "A list of (template-name template).") (defparameter *type-order* nil "The order in which types were declared in the configuration file. Determines the order in which stacks are dumped from push-test.") (defparameter *constant-instruction-values* nil "Storage for constant instructions created via CONSTANT lines in a configuration file and set via SETCONSTANT.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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 boolean->tnil (b) (case b (true t) (false nil))) (defun tnil->boolean (tnil) (if (null tnil) 'FALSE 'TRUE)) (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." (if (integerp n) (cond ((> n *max-positive-integer*) *max-positive-integer*) ((< n (- *max-positive-integer*)) (- *max-positive-integer*)) (t n)) (cond ((> n *max-positive-integer*) (float *max-positive-integer*)) ((< n (- *max-positive-integer*)) (float (- *max-positive-integer*))) ((and (< n *close-enough-to-zero*) (> n (- *close-enough-to-zero*))) 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) ) |# (defun symbol-concatenate (&rest symbols) "Returns a symbol formed from concatenating the print-names of all of the provided symbols." (intern (apply #'concatenate (cons 'string (mapcar #'(lambda (thing) (if (stringp thing) thing (symbol-name thing))) symbols))))) (defun spacey-parentheses (string) (let ((result (make-string 0)) (original-length (length string))) (dotimes (i original-length) (setq result (concatenate 'string result (let ((this-char (elt string i))) (case this-char (#\( "( ") (#\) " )") (otherwise (make-string 1 :initial-element this-char))))))) result)) ; (spacey-parentheses "(the (rain in (spain)) is ())") (defun define-constant-instruction (type-name constant-name) (eval `(defun ,constant-name () (let ((type (find-pushtype ',type-name)) (definition (find ',constant-name *constant-instruction-values* :key #'first))) (setf (pushtype-stack type) (cons (if definition (second definition) (pushtype-default type)) (pushtype-stack type))))))) (defun setconstant (constant-name value) (setq *constant-instruction-values* (cons (list constant-name value) (remove constant-name *constant-instruction-values* :key #'first)))) (defun configure-push-from-file (path) ;; note that the parameter lines in the config file have no special designation, ;; so you have to figure out which lines are parameters from the absence of other ;; designations (let ((config nil)) ;; read in the raw lines (with-open-file (f path :direction :input) (do ((the-line (read-line f nil nil) (read-line f nil nil))) ((not the-line)) (push the-line config))) ;; restore the order (setq config (reverse config)) ;; remove empty lines (setq config (remove-if #'(lambda (line) (= (length line) 0)) config)) ;; remove comments (setq config (remove-if #'(lambda (line) (eq (elt line 0) #\#)) config)) ;; convert to lists (setq config (mapcar #'(lambda (line) (read-from-string (concatenate 'string "(" line ")"))) config)) ;; set type order... (setq *type-order* (mapcar #'second (remove-if-not #'(lambda (line) (eq (first line) 'type)) config))) ;; use only active instructions (setq *push-instructions* (mapcar #'second (remove-if-not #'(lambda (line) (eq (first line) 'instruction)) config))) ;; active *ephemeral-random-constant-generators* (from active types) (setq *ephemeral-random-constant-generators* nil) (dolist (type-name *type-order*) (let ((type (find-pushtype type-name))) (if (pushtype-erc-generator type) (push (pushtype-erc-generator type) *ephemeral-random-constant-generators*)))) ;; add instructions for constants (setq *constant-instruction-values* nil) (dolist (constant-triple (remove-if-not #'(lambda (line) (eq (first line) 'constant)) config)) (define-constant-instruction (second constant-triple) (third constant-triple)) (push (third constant-triple) *push-instructions*)) ;; initialize instruction set (setq *instruction-set* (append *ephemeral-random-constant-generators* *push-instructions*)) ;; set parameters (let ((param-pairs (remove-if #'(lambda (line) (member (first line) (list 'type 'instruction 'constant))) config))) (dolist (pair param-pairs) (eval (read-from-string (format nil "(setq *~A* ~A)" (first pair) (second pair)))))) ;; *RANDOM-SEED* may be new; seed the random generator now (random::seed-state *RANDOM-SEED* *RANDOM-SEED*) 'configured)) ;; (configure-push-from-file (choose-file-dialog)) (defun push-test (directory) "Reads three files from the given directory: push.pconf, push.program, and push.input, and produces the file push.output in the same directory. The input file should contain a list of literals that will be used to initialize the stacks. The output file will contain a list of literals which, if read back in, would re-create the stacks at the end of the computation. The values in the output file are listed type by type, following the order in which types are declared in the configuration (pconf) file." ;; configure from the config file (configure-push-from-file (merge-pathnames (make-pathname :name "push.pconf") directory)) ;; get program and input from files (let ((program (with-open-file (p (merge-pathnames (make-pathname :name "push.program") directory) :direction :input) (read p))) (input (with-open-file (i (merge-pathnames (make-pathname :name "push.input") directory) :direction :input) (read i)))) ;; run the program on the input (runpush program input)) ;; print results to file (with-open-file (o (merge-pathnames (make-pathname :name "push.output") directory) :direction :output :if-exists :overwrite :if-does-not-exist :create) (format o "~A" (spacey-parentheses (format nil "~A" (apply #'append (mapcar #'(lambda (type-name) (reverse (pushtype-stack (find-pushtype type-name)))) *type-order*))))))) ;; (push-test (choose-directory-dialog)) (defun diff (path1 path2) "Compares the contents of the files at the two paths." (let ((input1 (with-open-file (i path1 :direction :input) (read i))) (input2 (with-open-file (i path2 :direction :input) (read i)))) ;; compare (let ((elements (max (length input1) (length input2)))) (dotimes (i elements) (unless (equalp (nth i input1) (nth i input2)) (format t "~%-----~%first file: ~A~%second file: ~A~%-----~%" (nth i input1)(nth i input2))))))) ;; (diff (choose-file-dialog) (choose-file-dialog)) (defun trim-ends (sym) "Returns a symbol like sym but without its first and last characters." (let ((name (symbol-name sym))) (intern (subseq name 1 (- (length name) 1))))) (defun generate-full-config-file (path) (with-open-file (o path :direction :output :if-exists :overwrite :if-does-not-exist :create) (format o "## Automatically generated Push configuration file") (format o "~%~%## PARAMETER SETTINGS") ;; currently don't print documentation, as it's not simple to get ;; it readable and commented out (dolist (param-triple *push-parameters*) (format o "~%~A ~A" (trim-ends (first param-triple)) (second param-triple) )) (format o "~%~%## TYPES") (dolist (type *pushtypes*) (format o "~%type ~A" (pushtype-name type))) (format o "~%~%## INSTRUCTIONS") (dolist (i *push-instructions*) (format o "~%instruction ~A" i)) (format o "~%~%## END OF PUSH INTERPRETER CONFIGURATION") )) ; (generate-full-config-file (choose-new-file-dialog)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; instruction templates (defmacro deftemplate (name &body body) `(progn (push (cons ',name ',body) *templates*) ',name)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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)))) (random-code-with-size actual-points))) (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." (if (member symbol *ephemeral-random-constant-generators*) (funcall symbol) symbol)) #| ;; 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)))) |# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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-pre-configuration must be called after the last call ;; to defpushtype. (defstruct pushtype name ; the name of the type stack ; storage for the stack for this type default ; a default value, for GET with unbound variables instructions ; instructions implemented for this type templates ; bindings ; stores variable bindings of this type for SET and GET erc-generator ; ephemeral random const generator or NIL for none rand-generator ; random instance generator or NIL for none literal-recognizer ; literal recognizer or NIL for none ) (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-pre-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*) (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*) (format t "~%~A STACK: ~A" (pushtype-name type) (pushtype-stack type))) (format t "~%") (values)) #-MCL(defun without-warnings (x) x) #+OPENMCL(defun without-warnings (x) x) (defun define-instruction-from-template (instruction-name type-name template-name) (without-warnings (compile instruction-name `(lambda () (let ((type (find-pushtype ',type-name))) ,(second (find template-name *templates* :key #'first)))))) ) (defun create-templated-instructions (type-name template-names) (mapcar #'(lambda (template-name) (let ((instruction-name (symbol-concatenate type-name "." template-name))) (define-instruction-from-template instruction-name type-name template-name) instruction-name)) template-names)) (defmacro defpushtype (type-name &key (default nil) (instructions nil) (templates nil) (erc-generator nil) (rand-generator nil) (literal-recognizer nil)) "Defines a new pushtype; see documentation of the pushtype structure." `(progn (push (make-pushtype :name ',type-name :stack nil :default ,default :instructions ',instructions :templates ',templates :bindings nil :erc-generator ',erc-generator :rand-generator ',rand-generator :literal-recognizer ',literal-recognizer) *pushtypes*) ',type-name)) (defun complete-push-pre-configuration () "Should be called after all DEFPUSHTYPE forms. Initializes many globals." ;; seed the random number generator with the provided seed (random::seed-state *RANDOM-SEED* *RANDOM-SEED*) ;; create templated instructions and initialize the list of all push instructions (setq *push-instructions* nil) (dolist (type *pushtypes*) (setf (pushtype-instructions type) (append (pushtype-instructions type) (create-templated-instructions (pushtype-name type) (pushtype-templates type)))) (dolist (instr (pushtype-instructions type)) (pushnew instr *push-instructions*))) ;; initialize pushtype hashtable (setq *pushtype-hashtable* (make-hash-table)) (dolist (type *pushtypes*) (setf (gethash (pushtype-name type) *pushtype-hashtable*) type)) ;; evaluate generators/recognizers (dolist (type *pushtypes*) (setf (pushtype-erc-generator type) (eval (pushtype-erc-generator type)) (pushtype-rand-generator type) (eval (pushtype-rand-generator type)) (pushtype-literal-recognizer type) (eval (pushtype-literal-recognizer type)))) ;; collect *ephemeral-random-constant-generators* (setq *ephemeral-random-constant-generators* nil) (dolist (type *pushtypes*) (if (pushtype-erc-generator type) (push (pushtype-erc-generator type) *ephemeral-random-constant-generators*))) ;; initialize instruction set (setq *instruction-set* (append *ephemeral-random-constant-generators* ;; random literals *push-instructions* ;; defined instructions ))) ;; add *push-names*? (defun instructions-for-type (typename) "Returns a list of all of the instructions for the named type." (pushtype-instructions (find-pushtype typename))) (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 &optional initial-stack-values) "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 values onto the appropriate stacks (dolist (value initial-stack-values) (let ((type (recognize-literal value))) (when type (push value (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 (listp tree) (mapc #'evalpush tree) ;; recurse on lists (execute-instruction tree)))) (values)) ;; don't return anything (defun types-with-name-last () (let ((name-type (find-pushtype 'name))) (if (member name-type *pushtypes*) (append (remove name-type *pushtypes*) (list name-type)) *pushtypes*))) (defun recognize-literal (thing) "Runs all of the literal recognizers on thing and returns the type of the first one that matches, or NIL if none do." (let ((type nil)) (dolist (thetype (types-with-name-last)) (when (pushtype-literal-recognizer thetype) (when (funcall (pushtype-literal-recognizer thetype) thing) (setq type thetype) (return)))) type)) (defun execute-instruction (instruction) "Executes a single push instruction." (let ((type (recognize-literal instruction))) (cond (type (push instruction (pushtype-stack type))) (t (when *track-calls* (track instruction)) (funcall instruction))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; template definitions -- TYPE will be bound to the appropriate type ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; templates for ALL types (deftemplate dup (unless (null (pushtype-stack type)) (push (copy-tree (first (pushtype-stack type))) (pushtype-stack type)))) (deftemplate pop (unless (null (pushtype-stack type)) (setf (pushtype-stack type) (rest (pushtype-stack type))))) (deftemplate swap (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)))))))) (deftemplate = (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 (tnil->boolean answer) (pushtype-stack boolean-type)))))) (deftemplate set (let ((name-type (find-pushtype 'name))) (unless (or (null (pushtype-stack name-type)) (case (pushtype-name type) (name (null (rest (pushtype-stack name-type)))) (t (null (pushtype-stack type))))) (let ((name-to-bind (first (pushtype-stack name-type)))) ;; pop the name stack here, in case we're doing NAME.SET (pop (pushtype-stack name-type)) (setf (pushtype-bindings type) (acons name-to-bind (first (pushtype-stack type)) (pushtype-bindings type))) (pop (pushtype-stack type)))))) (deftemplate get (let ((name-type (find-pushtype 'name))) (unless (null (pushtype-stack name-type)) (let ((the-name (first (pushtype-stack name-type)))) (when (assoc the-name (pushtype-bindings type)) ;; pop the name stack here in case we're doing NAME.GET (pop (pushtype-stack name-type)) (push (copy-tree (cdr (assoc the-name (pushtype-bindings type)))) (pushtype-stack type))))))) (deftemplate yank (let ((int (find-pushtype 'integer))) (unless (or (null (pushtype-stack int)) (case (pushtype-name type) (integer (null (rest (pushtype-stack int)))) (t (null (pushtype-stack type))))) (let ((raw-yank-index (first (pushtype-stack int)))) ;; pop the int stack here, regardless of what happens later (setf (pushtype-stack int) (rest (pushtype-stack int))) (let ((yank-index (max 0 (min raw-yank-index (- (length (pushtype-stack type)) 1))))) (unless (< (length (pushtype-stack type)) 2) ;; stack size might have changed (setf (pushtype-stack type) (cons (nth yank-index (pushtype-stack type)) (append (subseq (pushtype-stack type) 0 yank-index) (if (< yank-index (length (pushtype-stack type))) (subseq (pushtype-stack type) (1+ yank-index)) nil)))))))))) (deftemplate yankdup (let ((int (find-pushtype 'integer))) (unless (or (null (pushtype-stack int)) (case (pushtype-name type) (integer (null (rest (pushtype-stack int)))) (t (null (pushtype-stack type))))) (let ((raw-yank-index (first (pushtype-stack int)))) ;; pop the int stack here, regardless of what happens later (setf (pushtype-stack int) (rest (pushtype-stack int))) (let ((yank-index (max 0 (min raw-yank-index (- (length (pushtype-stack type)) 1))))) (unless (< (length (pushtype-stack type)) 2) (setf (pushtype-stack type) (cons (copy-tree (nth yank-index (pushtype-stack type))) (pushtype-stack type))))))))) (deftemplate shove (let ((int (find-pushtype 'integer))) (unless (or (null (pushtype-stack int)) (case (pushtype-name type) (integer (null (rest (pushtype-stack int)))) (t (null (pushtype-stack type))))) (let ((raw-shove-index (first (pushtype-stack int)))) ;; pop the int stack here, regardless of what happens later (setf (pushtype-stack int) (rest (pushtype-stack int))) (let ((shove-index (max 0 (min raw-shove-index (- (length (pushtype-stack type)) 1))))) (unless (< (length (pushtype-stack type)) 2) (setf (pushtype-stack type) (append (subseq (pushtype-stack type) 1 (+ 1 shove-index)) (list (first (pushtype-stack type))) (if (< shove-index (length (pushtype-stack type))) (subseq (pushtype-stack type) (1+ shove-index)) nil) )))))))) (deftemplate rand (push (funcall (pushtype-rand-generator type)) (pushtype-stack type))) (deftemplate stackdepth (let ((int (find-pushtype 'integer))) (setf (pushtype-stack int) (cons (length (pushtype-stack type)) (pushtype-stack int))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; templates primarily for CODE (deftemplate quote (setq *quote-destination* type)) (deftemplate atom (let ((stack (pushtype-stack type)) (bool (find-pushtype 'boolean))) (unless (null stack) (setf (pushtype-stack bool) (cons (tnil->boolean (atom (first stack))) (pushtype-stack bool)))) (pop (pushtype-stack type)))) (deftemplate null (let ((stack (pushtype-stack type)) (bool (find-pushtype 'boolean))) (unless (null stack) (setf (pushtype-stack bool) (cons (tnil->boolean (null (first stack))) (pushtype-stack bool)))) (pop (pushtype-stack type)))) (deftemplate car (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))))))) (deftemplate cdr (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))))))) (deftemplate cons (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))))))))) (deftemplate instructions (setf (pushtype-stack type) (push *push-instructions* (pushtype-stack type)))) (deftemplate do* (unless (null (pushtype-stack type)) (let ((to-do (first (pushtype-stack type)))) (pop (pushtype-stack type)) (evalpush to-do)))) (deftemplate do (unless (null (pushtype-stack type)) (evalpush (copy-tree (first (pushtype-stack type)))) (pop (pushtype-stack type)))) (deftemplate if (let ((boolean-type (find-pushtype 'boolean))) (unless (or (null (pushtype-stack boolean-type)) (null (rest (pushtype-stack type)))) (let ((to-do (if (boolean->tnil (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) )))) (deftemplate noop (declare (ignore type))) (deftemplate list (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))))))) (deftemplate append (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))))))))) (deftemplate nth (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)))))) (deftemplate nthcdr (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)))))) (deftemplate member (let ((stack (pushtype-stack type)) (bool (find-pushtype 'boolean))) (unless (null (rest stack)) (push (if (member (second stack) (ensure-list (first stack)) :test #'equalp) 'TRUE 'FALSE) (pushtype-stack bool)) (pop (pushtype-stack type)) (pop (pushtype-stack type))))) (deftemplate position (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))))) (deftemplate contains (let ((stack (pushtype-stack type)) (bool (find-pushtype 'boolean))) (unless (null (rest stack)) (push (tnil->boolean (contains-subtree (second stack) (first stack))) (pushtype-stack bool))) (pop (pushtype-stack type)))) (deftemplate insert (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))))))) (deftemplate extract (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)))))) (deftemplate length (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))))) (deftemplate size (let ((stack (pushtype-stack type)) (int (find-pushtype 'integer))) (unless (null stack) (push (count-points (first stack)) (pushtype-stack int)) (pop (pushtype-stack type))))) (deftemplate do (unless (null (pushtype-stack type)) (evalpush (copy-tree (first (pushtype-stack type)))) (pop (pushtype-stack type)))) (deftemplate subst (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)))))))))))) (deftemplate container (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)))))))) (deftemplate discrepancy (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))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; templates for numbers (deftemplate + (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))))))) (deftemplate - (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))))))) (deftemplate * (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))))))) ;; works for integer and float only at the moment (deftemplate / (let ((stack-contents (pushtype-stack type))) (unless (or (null (rest stack-contents)) (zerop (first stack-contents))) (setf (pushtype-stack type) (cons (let ((raw-result (keep-number-reasonable (/ (second stack-contents) (first stack-contents))))) (case (pushtype-name type) (integer (truncate raw-result)) (float (float raw-result)))) (rest (rest stack-contents))))))) ;; works for integer and float only at the moment (deftemplate % (let ((stack-contents (pushtype-stack type))) (unless (or (null (rest stack-contents)) (zerop (first stack-contents))) (setf (pushtype-stack type) (cons (let ((raw-result (keep-number-reasonable (mod (second stack-contents) (first stack-contents))))) (case (pushtype-name type) (integer (truncate raw-result)) (float (float raw-result)))) (rest (rest stack-contents))))))) (deftemplate min (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))))))) (deftemplate max (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))))))) (deftemplate < (let ((stack-contents (pushtype-stack type)) (boolean-type (find-pushtype 'boolean))) (unless (null (rest stack-contents)) (push (tnil->boolean (< (second stack-contents) (first stack-contents))) (pushtype-stack boolean-type)) (setf (pushtype-stack type) (rest (rest stack-contents)))))) (deftemplate > (let ((stack-contents (pushtype-stack type)) (boolean-type (find-pushtype 'boolean))) (unless (null (rest stack-contents)) (push (tnil->boolean (> (second stack-contents) (first stack-contents))) (pushtype-stack boolean-type)) (setf (pushtype-stack type) (rest (rest stack-contents)))))) (deftemplate sin (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)))))) (deftemplate cos (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)))))) (deftemplate tan (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)))))) ;; conversions among floats, integers, and booleans (deftemplate fromfloat ;; to integer by truncation, to boolean by zerop (let ((float-type (find-pushtype 'float))) (unless (null (pushtype-stack float-type)) (push (case (pushtype-name type) (integer (truncate (first (pushtype-stack float-type)))) (boolean (if (zerop (first (pushtype-stack float-type))) 'FALSE 'TRUE))) (pushtype-stack type)) (setf (pushtype-stack float-type) (rest (pushtype-stack float-type)))))) (deftemplate frominteger ;; to float by *1.0, to boolean by zerop (let ((int-type (find-pushtype 'integer))) (unless (null (pushtype-stack int-type)) (push (case (pushtype-name type) (float (* 1.0 (first (pushtype-stack int-type)))) (boolean (if (zerop (first (pushtype-stack int-type))) 'FALSE 'TRUE))) (pushtype-stack type)) (setf (pushtype-stack int-type) (rest (pushtype-stack int-type)))))) (deftemplate fromboolean ;; to integer and float by 1/0 (let ((bool-type (find-pushtype 'boolean))) (unless (null (pushtype-stack bool-type)) (push (case (pushtype-name type) (integer (if (eq (first (pushtype-stack bool-type)) 'TRUE) 1 0)) (float (if (eq (first (pushtype-stack bool-type)) 'TRUE) 1.0 0.0))) (pushtype-stack type)) (setf (pushtype-stack bool-type) (rest (pushtype-stack bool-type)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; templates for booleans (deftemplate and (let ((stack-contents (pushtype-stack type))) (unless (null (rest stack-contents)) (setf (pushtype-stack type) (cons (tnil->boolean (and (boolean->tnil (second stack-contents)) (boolean->tnil (first stack-contents)))) (rest (rest stack-contents))))))) (deftemplate or (let ((stack-contents (pushtype-stack type))) (unless (null (rest stack-contents)) (setf (pushtype-stack type) (cons (tnil->boolean (or (boolean->tnil (second stack-contents)) (boolean->tnil (first stack-contents)))) (rest (rest stack-contents))))))) (deftemplate not (let ((stack-contents (pushtype-stack type))) (unless (null stack-contents) (setf (pushtype-stack type) (cons (tnil->boolean (not (boolean->tnil (first stack-contents)))) (rest stack-contents)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; templates for names (deftemplate randboundname (setf (pushtype-stack type) (cons (random-element (apply #'append (mapcar #'(lambda (x) (mapcar #'car (pushtype-bindings x))) *pushtypes*))) (pushtype-stack type)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; definitions for push types ;; INTEGER TYPE (defun ephemeral-random-integer () (+ (randint (+ 1 (- *MAX-RANDOM-INTEGER* *MIN-RANDOM-INTEGER*))) *MIN-RANDOM-INTEGER*)) (defpushtype integer :default 0 :templates (dup pop swap = yank yankdup shove stackdepth rand set get + - * / % min max < > fromfloat fromboolean ) :instructions nil :erc-generator #'ephemeral-random-integer :rand-generator #'ephemeral-random-integer :literal-recognizer #'integerp ) ;; BOOLEAN TYPE (defun ephemeral-random-boolean () (if (zerop (randint 2)) 'FALSE 'TRUE)) (defpushtype boolean :default 'FALSE :templates (dup pop swap = yank yankdup shove stackdepth rand set get and or not frominteger fromfloat ) :erc-generator #'ephemeral-random-boolean :rand-generator #'ephemeral-random-boolean :literal-recognizer #'(lambda (x) (or (eq x 'TRUE) (eq x 'FALSE))) ) ;; CODE TYPE (defun randcode () "A version of rand specialized for code. An integer argument is used to limit the size of the expression (and is then popped)." (let ((int (find-pushtype 'integer))) (unless (null (pushtype-stack int)) (let ((the-int (first (pushtype-stack int)))) (pop (pushtype-stack int)) (random-code (abs (mod the-int *max-points-in-random-expressions*))))))) (defpushtype code :default '( ) :rand-generator #'randcode :templates (dup pop swap = yank yankdup shove stackdepth rand set get quote atom null car cdr cons instructions do* if noop list append nth nthcdr member position contains insert extract length size do subst container discrepancy ) ) ;; NAME TYPE (defun ephemeral-random-name () (if (or (null *push-names*) (> *new-erc-name-probability* (randfloat 1))) (let ((new-symbol (gentemp "ERC-VAR-"))) (push new-symbol *push-names*) new-symbol) (random-element *push-names*))) (defun randname () "A version of rand specialized for the name type. The name 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-"))) new-symbol ;(push new-symbol *push-names*) ;; in some applications this makes *push-names* way too huge )) (defpushtype name :default 'DEFAULT-NAME :templates (dup pop swap = yank yankdup shove stackdepth rand set get randboundname) :erc-generator #'ephemeral-random-name :rand-generator #'randname :literal-recognizer #'(lambda (x) (and (symbolp x) (not (member x (append *push-instructions* (list t nil)))))) ) ;; FLOAT TYPE (defun ephemeral-random-float () (+ (randfloat (- *MAX-RANDOM-FLOAT* *MIN-RANDOM-FLOAT*)) *MIN-RANDOM-FLOAT*)) (defpushtype float :default 0.0 :templates (dup pop swap = yank yankdup shove stackdepth rand set get + - * / % min max < > sin cos tan frominteger fromboolean) :instructions nil :erc-generator #'ephemeral-random-float :rand-generator #'ephemeral-random-float :literal-recognizer #'floatp ) ;; this is required after the last call to defpushtype (complete-push-pre-configuration)