;;; -*- mode: Lisp; Syntax: Common-Lisp; -*- ;;; ;;; Copyright (c) 2009 by the authors. ;;; ;;; See LICENCE for details. (in-package :hu.dwim.genetic-programming) ;;;;;; ;;; Form generator (def (structure e) generator (boolean-constant-form-generator 'make-random-boolean-constant-form :type (or symbol function)) (integer-constant-form-generator 'make-random-integer-constant-form :type (or symbol function)) (number-constant-form-generator 'make-random-number-constant-form :type (or symbol function)) (constant-form-generator 'make-random-constant-form :type (or symbol function)) (variable-reference-form-generator 'make-random-variable-reference-form :type (or symbol function)) (if-form-generator 'make-random-if-form :type (or symbol function)) (flet-form-generator 'make-random-flet-form :type (or symbol function)) (free-application-form-generator 'make-random-free-application-form :type (or symbol function)) (form-generator 'make-random-form :type (or symbol function)) (lambda-form-generator 'make-random-lambda-form :type (or symbol function))) (def (function e) generate-boolean-constant-form (&rest args &key generator &allow-other-keys) (apply (generator-boolean-constant-form-generator generator) args)) (def (function e) generate-integer-constant-form (&rest args &key generator &allow-other-keys) (apply (generator-integer-constant-form-generator generator) args)) (def (function e) generate-number-constant-form (&rest args &key generator &allow-other-keys) (apply (generator-number-constant-form-generator generator) args)) (def (function e) generate-constant-form (&rest args &key generator &allow-other-keys) (apply (generator-constant-form-generator generator) args)) (def (function e) generate-variable-reference-form (&rest args &key generator &allow-other-keys) (apply (generator-variable-reference-form-generator generator) args)) (def (function e) generate-if-form (&rest args &key generator &allow-other-keys) (apply (generator-if-form-generator generator) args)) (def (function e) generate-flet-form (&rest args &key generator &allow-other-keys) (apply (generator-flet-form-generator generator) args)) (def (function e) generate-free-application-form (&rest args &key generator &allow-other-keys) (apply (generator-free-application-form-generator generator) args)) (def (function e) generate-form (&rest args &key generator &allow-other-keys) (apply (generator-form-generator generator) args)) (def (function e) generate-lambda-form (&rest args &key generator &allow-other-keys) (apply (generator-lambda-form-generator generator) args)) ;;;;;; ;;; Default form generator (def constant +default-return-type+ t) (def constant +default-minimum-depth+ 0) (def constant +default-maximum-depth+ 10) (def constant +default-form-types+ '(constant-form variable-reference-form if-form free-application-form)) (def (function e) make-random-boolean-constant-form (&rest args &key (generator (make-generator)) (return-type 'boolean)) (declare (ignore generator return-type)) (make-instance 'constant-form :attributes args :value (zerop (random 2)))) (def (function e) make-random-integer-constant-form (&rest args &key (generator (make-generator)) (return-type 'integer)) (declare (ignore generator)) (make-instance 'constant-form :attributes args :value (if (consp return-type) (bind ((lower-bound (second return-type)) (upper-bound (third return-type))) (+ lower-bound (random (1+ (- upper-bound lower-bound))))) (random 100)))) (def (function e) make-random-number-constant-form (&rest args &key (generator (make-generator)) (return-type 'number)) (declare (ignore generator return-type)) (make-instance 'constant-form :attributes args :value (random 2.0))) (def (function e) make-random-constant-form (&rest args &key (generator (make-generator)) (return-type +default-return-type+)) (etypecase return-type (symbol (ecase return-type (boolean (generate-boolean-constant-form :generator generator :return-type return-type)) (integer (generate-integer-constant-form :generator generator :return-type return-type)) (number (generate-number-constant-form :generator generator :return-type return-type)) (t (generate-constant-form :generator generator :return-type (random-elt '(boolean integer number)))))) (cons (ecase (first return-type) (eql (make-instance 'constant-form :attributes args :value (second return-type))) (member (make-instance 'constant-form :attributes args :value (random-elt (rest return-type)))) (or (generate-constant-form :generator generator :return-type (random-elt (rest return-type)))) (integer (generate-integer-constant-form :generator generator :return-type return-type)))))) (def (function e) make-random-variable-reference-form (&rest args &key (generator (make-generator)) (return-type +default-return-type+) (lexical-variable-names nil) (lexical-variable-types (make-list (length lexical-variable-names) :initial-element t))) (declare (ignore generator)) (bind ((variable-name-type-pair (random-elt (iter (for lexical-variable-name :in lexical-variable-names) (for lexical-variable-type :in lexical-variable-types) (when (subtypep lexical-variable-type return-type) (collect (cons lexical-variable-name lexical-variable-type))))))) (make-instance 'variable-reference-form :name (car variable-name-type-pair) :declared-type (cdr variable-name-type-pair) :attributes args))) (def (function e) make-random-if-form (&rest args &key (generator (make-generator)) (return-type +default-form-types+) (depth 0) (minimum-depth +default-minimum-depth+) (maximum-depth +default-form-types+) (form-types +default-form-types+) (function-descriptors (hash-table-values *function-descriptors*)) (lexical-variable-names nil) (lexical-variable-types nil)) (bind ((non-constant-subform-index (random 3)) (condition-form (generate-form :generator generator :return-type 'boolean :depth depth :minimum-depth minimum-depth :maximum-depth maximum-depth :form-types (if (= non-constant-subform-index 0) (remove 'constant-form form-types) form-types) :lexical-variable-names lexical-variable-names :lexical-variable-types lexical-variable-types :function-descriptors function-descriptors)) (then-branch-form (generate-form :generator generator :return-type return-type :depth depth :minimum-depth minimum-depth :maximum-depth maximum-depth :form-types (if (= non-constant-subform-index 1) (remove 'constant-form form-types) form-types) :lexical-variable-names lexical-variable-names :lexical-variable-types lexical-variable-types :function-descriptors function-descriptors)) (else-branch-form (generate-form :generator generator :return-type return-type :depth depth :minimum-depth minimum-depth :maximum-depth maximum-depth :form-types (if (= non-constant-subform-index 2) (remove 'constant-form form-types) form-types) :lexical-variable-names lexical-variable-names :lexical-variable-types lexical-variable-types :function-descriptors function-descriptors))) (make-instance 'if-form :attributes args :condition condition-form :then then-branch-form :else else-branch-form))) (def (function e) make-random-flet-form (&rest args &key (generator (make-generator)) (return-type +default-return-type+) (depth 0) (minimum-depth +default-minimum-depth+) (maximum-depth +default-maximum-depth+) (form-types +default-form-types+) (function-descriptors (hash-table-values *function-descriptors*)) (lexical-variable-names nil) (lexical-variable-types (make-list (length lexical-variable-names) :initial-element t))) (bind ((name 'local) (argument-names '(a b)) (argument-types '(number number)) (local-return-type 'number) (local-function-descriptor (make-function-descriptor :name name :argument-types argument-types :return-type local-return-type)) (new-form-types (remove-if (lambda (form-type) (member form-type '(constant-form flet-form))) form-types))) ;; KLUDGE: (setf (find-function-descriptor name) local-function-descriptor) (make-instance 'flet-form :attributes args :bindings (list (make-instance 'lexical-function-form :name name :bindings (mapcar (lambda (argument-name) (make-instance 'required-function-argument-form :name argument-name)) argument-names) :body (list (generate-form :generator generator :return-type return-type :depth depth :minimum-depth (+ depth minimum-depth) :maximum-depth (+ depth maximum-depth) :form-types new-form-types :lexical-variable-names argument-names :lexical-variable-types argument-types :function-descriptors function-descriptors)))) :body (list (generate-form :generator generator :return-type return-type :depth depth :minimum-depth minimum-depth :maximum-depth maximum-depth :form-types new-form-types :lexical-variable-names lexical-variable-names :lexical-variable-types lexical-variable-types :function-descriptors (list* local-function-descriptor function-descriptors)))))) (def (function e) make-random-free-application-form (&rest args &key (generator (make-generator)) (return-type +default-return-type+) (depth 0) (minimum-depth +default-minimum-depth+) (maximum-depth +default-maximum-depth+) (form-types +default-form-types+) (function-descriptors (hash-table-values *function-descriptors*)) (lexical-variable-names nil) (lexical-variable-types (make-list (length lexical-variable-names) :initial-element t))) (bind ((function-descriptor (random-elt (collect-matching-function-descriptors return-type nil function-descriptors))) (argument-types (function-descriptor-argument-types function-descriptor)) (non-constant-argument-form-index (unless (zerop (length argument-types)) (random (length argument-types)))) (argument-forms (iter (for index :from 0) (for argument-type :in argument-types) (collect (generate-form :generator generator :return-type argument-type :depth depth :minimum-depth minimum-depth :maximum-depth maximum-depth :form-types (if (eq index non-constant-argument-form-index) (remove 'constant-form form-types) form-types) :lexical-variable-names lexical-variable-names :lexical-variable-types lexical-variable-types :function-descriptors function-descriptors))))) (make-instance 'free-application-form :attributes args :operator (function-descriptor-name function-descriptor) :arguments argument-forms))) (def (function e) make-random-form (&key (generator (make-generator)) (return-type +default-return-type+) (depth 0) (minimum-depth +default-minimum-depth+) (maximum-depth +default-maximum-depth+) (form-types +default-form-types+) (function-descriptors (hash-table-values *function-descriptors*)) (lexical-variable-names nil) (lexical-variable-types (make-list (length lexical-variable-names) :initial-element t))) (bind ((available-form-types (remove-if (lambda (form-type) (case form-type (constant-form (not (zerop minimum-depth))) (variable-reference-form (or (not (zerop minimum-depth)) (not lexical-variable-names))) (if-form t #+nil(zerop maximum-depth)) (flet-form (not (zerop depth))) (free-application-form (zerop maximum-depth)))) form-types)) (new-depth (1+ depth)) (new-minimum-depth (max 0 (1- minimum-depth))) (new-maximum-depth (max 0 (1- maximum-depth))) (new-form-types (cons 'constant-form form-types))) (ecase (random-elt available-form-types) (constant-form (generate-constant-form :generator generator :return-type return-type)) (variable-reference-form (generate-variable-reference-form :generator generator :return-type return-type :lexical-variable-names lexical-variable-names :lexical-variable-types lexical-variable-types)) (if-form (generate-if-form :generator generator :return-type return-type :depth new-depth :minimum-depth new-minimum-depth :maximum-depth new-maximum-depth :form-types new-form-types :lexical-variable-names lexical-variable-names :lexical-variable-types lexical-variable-types :function-descriptors function-descriptors)) (flet-form (generate-flet-form :generator generator :return-type return-type :depth new-depth :minimum-depth new-minimum-depth :maximum-depth new-maximum-depth :form-types new-form-types :lexical-variable-names lexical-variable-names :lexical-variable-types lexical-variable-types :function-descriptors function-descriptors)) (free-application-form (generate-free-application-form :generator generator :return-type return-type :depth new-depth :minimum-depth new-minimum-depth :maximum-depth new-maximum-depth :form-types new-form-types :lexical-variable-names lexical-variable-names :lexical-variable-types lexical-variable-types :function-descriptors function-descriptors))))) (def (function e) make-random-lambda-form (&rest args &key (generator (make-generator)) (return-type +default-return-type+) (minimum-depth +default-minimum-depth+) (maximum-depth +default-maximum-depth+) (form-types +default-form-types+) (function-descriptors (hash-table-values *function-descriptors*)) (argument-names nil) (argument-types (make-list (length argument-names) :initial-element t))) (make-instance 'lambda-function-form :attributes args :bindings (mapcar (lambda (argument-name) (make-instance 'required-function-argument-form :name argument-name)) argument-names) :declarations (append (mapcar (lambda (argument-name) (make-instance 'variable-ignorable-declaration-form :name argument-name)) argument-names) (mapcar (lambda (argument-name argument-type) (make-instance 'type-declaration-form :name argument-name :declared-type argument-type)) argument-names argument-types)) :body (list (generate-form :generator generator :return-type return-type :depth 0 :minimum-depth minimum-depth :maximum-depth maximum-depth :form-types (remove 'constant-form (if argument-names form-types (remove 'variable-reference-form form-types))) :lexical-variable-names argument-names :lexical-variable-types argument-types :function-descriptors function-descriptors)))) ;;;;;; ;;; Utilities (def constant +rewritable-form-types+ '(or constant-form variable-reference-form free-application-form)) (def function form= (form-1 form-2) (equal (unwalk-form form-1) (unwalk-form form-2))) (def function count-forms (walked-form form-types) (bind ((count 0)) (map-ast (lambda (form) (when (typep form form-types) (incf count)) form) walked-form) count)) (def function find-nth-form (walked-form form-types index) (bind ((current-index 0)) (map-ast (lambda (form) (when (typep form form-types) (when (= current-index index) (return-from find-nth-form form)) (incf current-index)) form) walked-form))) (def function rewrite-nth-form (walked-form form-types index replacement-form-generator) (bind ((current-index 0)) (rewrite-ast walked-form (lambda (parent field form) (declare (ignore parent field)) (if (typep form form-types) (if (= index current-index) (funcall replacement-form-generator form) (progn (incf current-index) form)) form)))))