Merge remote-tracking branch 'upstream/master'
This commit is contained in:
Nic McPhee
commit
5c4d033c4f
8
.gitignore
vendored
8
.gitignore
vendored
@ -15,3 +15,11 @@ pom.xml.asc
|
||||
out
|
||||
notes
|
||||
.clj-kondo/
|
||||
.idea/
|
||||
.calva/
|
||||
|
||||
# Don't commit the data directory that we'll
|
||||
# use to hold the data from
|
||||
# https://github.com/thelmuth/program-synthesis-benchmark-datasets
|
||||
/data
|
||||
**/.DS_Store
|
||||
|
||||
@ -4,6 +4,7 @@
|
||||
:license {:name "EPL-2.0 OR GPL-2.0-or-later WITH Classpath-exception-2.0"
|
||||
:url "https://www.eclipse.org/legal/epl-2.0/"}
|
||||
:dependencies [[org.clojure/clojure "1.10.0"]
|
||||
[org.clojure/clojurescript "1.9.946"]]
|
||||
[org.clojure/clojurescript "1.9.946"]
|
||||
[org.clojure/test.check "1.1.0"]]
|
||||
:main ^:skip-aot propeller.core
|
||||
:repl-options {:init-ns propeller.core})
|
||||
|
||||
BIN
src/.DS_Store
vendored
BIN
src/.DS_Store
vendored
Binary file not shown.
BIN
src/propeller/.DS_Store
vendored
BIN
src/propeller/.DS_Store
vendored
Binary file not shown.
@ -25,8 +25,12 @@
|
||||
(println "Best behaviors:" (:behaviors best))
|
||||
(println "Genotypic diversity:"
|
||||
(float (/ (count (distinct (map :plushy pop))) (count pop))))
|
||||
(println "Behavioral diversity:"
|
||||
(float (/ (count (distinct (map :behaviors pop))) (count pop))))
|
||||
(println "Average genome length:"
|
||||
(float (/ (reduce + (map count (map :plushy pop))) (count pop))))
|
||||
(println "Average total error:"
|
||||
(float (/ (reduce + (map :total-error pop)) (count pop))))
|
||||
(println)))
|
||||
|
||||
(defn gp
|
||||
|
||||
62
src/propeller/problems/valiant.cljc
Normal file
62
src/propeller/problems/valiant.cljc
Normal file
@ -0,0 +1,62 @@
|
||||
(ns propeller.problems.valiant
|
||||
(:require [propeller.genome :as genome]
|
||||
[propeller.push.interpreter :as interpreter]
|
||||
[propeller.push.state :as state]))
|
||||
|
||||
(def num-vars 100) ;10) ;100) ;1000)
|
||||
(def num-inputs 50) ;5) ; 50) ;500)
|
||||
(def num-train 500) ;5000)
|
||||
(def num-test 200)
|
||||
|
||||
(def train-and-test-data
|
||||
(let [input-indices (take num-inputs (shuffle (range num-vars)))
|
||||
rand-vars (fn [] (vec (repeatedly num-vars #(< (rand) 0.5))))
|
||||
even-parity? (fn [vars]
|
||||
(even? (count (filter #(= % true)
|
||||
(map #(nth vars %)
|
||||
input-indices)))))
|
||||
train-inputs (repeatedly num-train rand-vars)
|
||||
test-inputs (repeatedly num-test rand-vars)]
|
||||
{:train {:inputs train-inputs
|
||||
:outputs (map even-parity? train-inputs)}
|
||||
:test {:inputs test-inputs
|
||||
:outputs (map even-parity? test-inputs)}}))
|
||||
|
||||
(def instructions
|
||||
(vec (concat (for [i (range num-vars)] (keyword (str "in" i)))
|
||||
(take num-inputs
|
||||
(cycle [:boolean_xor
|
||||
:boolean_or
|
||||
:boolean_and
|
||||
:boolean_not
|
||||
:exec_if
|
||||
'close
|
||||
])))))
|
||||
|
||||
(defn error-function
|
||||
([argmap individual]
|
||||
(error-function argmap individual :train))
|
||||
([argmap individual subset]
|
||||
(let [program (genome/plushy->push (:plushy individual) argmap)
|
||||
data (get train-and-test-data subset)
|
||||
inputs (:inputs data)
|
||||
correct-outputs (:outputs data)
|
||||
outputs (map (fn [input]
|
||||
(state/peek-stack
|
||||
(interpreter/interpret-program
|
||||
program
|
||||
(assoc state/empty-state
|
||||
:input (zipmap (for [i (range (count input))]
|
||||
(keyword (str "in" i)))
|
||||
input))
|
||||
(:step-limit argmap))
|
||||
:boolean))
|
||||
inputs)
|
||||
errors (map #(if (= %1 %2) 0 1)
|
||||
correct-outputs
|
||||
outputs)]
|
||||
(assoc individual
|
||||
:behaviors outputs
|
||||
:errors errors
|
||||
:total-error #?(:clj (apply +' errors)
|
||||
:cljs (apply + errors))))))
|
||||
@ -52,12 +52,16 @@
|
||||
(make-instruction state empty? [stack] :boolean)))
|
||||
|
||||
;; Pushes the first item of the top element of the vector stack onto the
|
||||
;; approrpiately-typed literal stack
|
||||
;; appropriately-typed literal stack. If the vector is empty, return
|
||||
;; :ignore-instruction so that nothing is changed on the stacks.
|
||||
(def _first
|
||||
^{:stacks #{:elem}}
|
||||
(fn [stack state]
|
||||
(let [lit-stack (get-vector-literal-type stack)]
|
||||
(make-instruction state first [stack] lit-stack))))
|
||||
(make-instruction state
|
||||
#(if (empty? %) :ignore-instruction (first %))
|
||||
[stack]
|
||||
lit-stack))))
|
||||
|
||||
;; Pushes onto the INTEGER stack the index of the top element of the
|
||||
;; appropriately-typed literal stack within the top element of the vector stack
|
||||
@ -97,7 +101,11 @@
|
||||
^{:stacks #{:elem}}
|
||||
(fn [stack state]
|
||||
(let [lit-stack (get-vector-literal-type stack)]
|
||||
(make-instruction state last [stack] lit-stack))))
|
||||
(make-instruction
|
||||
state
|
||||
#(if (empty? %) :ignore-instruction (last %))
|
||||
[stack]
|
||||
lit-stack))))
|
||||
|
||||
;; Pushes the length of the top item onto the INTEGER stack
|
||||
(def _length
|
||||
@ -113,7 +121,9 @@
|
||||
(fn [stack state]
|
||||
(let [lit-stack (get-vector-literal-type stack)]
|
||||
(make-instruction state
|
||||
#(get %2 (mod %1 (count %2)))
|
||||
#(if (empty? %2)
|
||||
:ignore-instruction
|
||||
(get %2 (mod %1 (count %2))))
|
||||
[:integer stack]
|
||||
lit-stack))))
|
||||
|
||||
@ -173,7 +183,10 @@
|
||||
(let [lit-stack (get-vector-literal-type stack)]
|
||||
(make-instruction state
|
||||
(fn [lit1 lit2 vect]
|
||||
(assoc vect (utils/indexof lit1 vect) lit2))
|
||||
(let [replaceindex (utils/indexof lit1 vect)]
|
||||
(if (= replaceindex -1)
|
||||
vect
|
||||
(assoc vect replaceindex lit2))))
|
||||
[lit-stack lit-stack stack]
|
||||
stack))))
|
||||
|
||||
@ -198,8 +211,10 @@
|
||||
(let [lit-stack (get-vector-literal-type stack)]
|
||||
(make-instruction state
|
||||
(fn [lit n vect]
|
||||
(assoc vect (mod n (count vect)) lit))
|
||||
[:integer lit-stack stack]
|
||||
(if (empty? vect)
|
||||
:ignore-instruction
|
||||
(assoc vect (mod n (count vect)) lit)))
|
||||
[lit-stack :integer stack]
|
||||
stack))))
|
||||
|
||||
;; Pushes a subvector of the top item, with start and end indices determined by
|
||||
@ -208,9 +223,9 @@
|
||||
^{:stacks #{:integer}}
|
||||
(fn [stack state]
|
||||
(make-instruction state
|
||||
(fn [stop-raw start-raw vect]
|
||||
(fn [start-raw stop-raw vect]
|
||||
(let [start (min (count vect) (max 0 start-raw))
|
||||
stop (min (count vect) (max start-raw stop-raw))]
|
||||
stop (min (count vect) (max 0 start-raw stop-raw))]
|
||||
(subvec vect start stop)))
|
||||
[:integer :integer stack]
|
||||
stack)))
|
||||
|
||||
@ -28,7 +28,11 @@
|
||||
;; A utility function for making Push instructions. Takes a state, a function
|
||||
;; to apply to the args, the stacks to take the args from, and the stack to
|
||||
;; return the result to. Applies the function to the args (popped from the
|
||||
;; given stacks), and pushes the result onto the return-stack
|
||||
;; given stacks), and pushes the result onto the return-stack.
|
||||
;;
|
||||
;; If the function returns :ignore-instruction, then we will return the
|
||||
;; initial state unchanged. This allows instructions to fail gracefully
|
||||
;; without consuming stack values.
|
||||
(defn make-instruction
|
||||
[state function arg-stacks return-stack]
|
||||
(let [popped-args (get-args-from-stacks state arg-stacks)]
|
||||
@ -36,7 +40,9 @@
|
||||
state
|
||||
(let [result (apply function (:args popped-args))
|
||||
new-state (:state popped-args)]
|
||||
(state/push-to-stack new-state return-stack result)))))
|
||||
(if (= result :ignore-instruction)
|
||||
state
|
||||
(state/push-to-stack new-state return-stack result))))))
|
||||
|
||||
;; Given a set of stacks, returns all instructions that operate on those stacks
|
||||
;; only. Won't include random instructions unless :random is in the set as well
|
||||
|
||||
@ -10,145 +10,146 @@
|
||||
[propeller.push.state :as state]
|
||||
[propeller.push.utils.helpers :refer [get-stack-instructions]]))
|
||||
|
||||
#_(interpreter/interpret-program
|
||||
'(1 2 :integer_add) state/empty-state 1000)
|
||||
|
||||
#_(interpreter/interpret-program
|
||||
'(3 3 :integer_eq :exec_if (1 "yes") (2 "no"))
|
||||
state/empty-state
|
||||
1000)
|
||||
|
||||
#_(interpreter/interpret-program
|
||||
'(:in1 :string_reverse 1 :string_take "?" :string_eq :exec_if
|
||||
(:in1 " I am asking." :string_concat)
|
||||
(:in1 " I am saying." :string_concat))
|
||||
(assoc state/empty-state :input {:in1 "Can you hear me?"})
|
||||
1000)
|
||||
|
||||
#_(interpreter/interpret-program
|
||||
'(:in1 :string_reverse 1 :string_take "?" :string_eq :exec_if
|
||||
(:in1 " I am asking." :string_concat)
|
||||
(:in1 " I am saying." :string_concat))
|
||||
(assoc state/empty-state :input {:in1 "I can hear you."})
|
||||
1000)
|
||||
|
||||
#_(genome/plushy->push
|
||||
(genome/make-random-plushy (get-stack-instructions #{:float :integer :exec :boolean}) 20))
|
||||
|
||||
#_(gp/gp {:instructions propeller.problems.software.number-io/instructions
|
||||
:error-function propeller.problems.software.number-io/error-function
|
||||
:max-generations 500
|
||||
:population-size 500
|
||||
:max-initial-plushy-size 100
|
||||
:step-limit 200
|
||||
:parent-selection :lexicase
|
||||
:tournament-size 5
|
||||
:umad-rate 0.1
|
||||
:variation {:umad 0.5 :crossover 0.5}
|
||||
:elitism false})
|
||||
|
||||
#_(gp/gp {:instructions propeller.problems.simple-regression/instructions
|
||||
:error-function propeller.problems.simple-regression/error-function
|
||||
:max-generations 500
|
||||
:population-size 500
|
||||
:max-initial-plushy-size 100
|
||||
:step-limit 200
|
||||
:parent-selection :tournament
|
||||
:tournament-size 5
|
||||
:umad-rate 0.01
|
||||
:variation {:umad 1.0
|
||||
:crossover 0.0}
|
||||
:elitism false})
|
||||
|
||||
#_(gp/gp {:instructions propeller.problems.simple-regression/instructions
|
||||
:error-function propeller.problems.simple-regression/error-function
|
||||
:max-generations 500
|
||||
:population-size 500
|
||||
:max-initial-plushy-size 100
|
||||
:step-limit 200
|
||||
:parent-selection :tournament
|
||||
:tournament-size 5
|
||||
:umad-rate 0.1
|
||||
:variation {:umad 1.0
|
||||
:crossover 0.0}
|
||||
:elitism false})
|
||||
|
||||
|
||||
#_(gp/gp {:instructions propeller.problems.simple-regression/instructions
|
||||
:error-function propeller.problems.simple-regression/error-function
|
||||
:max-generations 500
|
||||
:population-size 500
|
||||
:max-initial-plushy-size 100
|
||||
:step-limit 200
|
||||
:parent-selection :lexicase
|
||||
:tournament-size 5
|
||||
:umad-rate 0.1
|
||||
:variation {:umad 1.0
|
||||
:crossover 0.0}
|
||||
:elitism false})
|
||||
|
||||
#_(gp/gp {:instructions propeller.problems.simple-regression/instructions
|
||||
:error-function propeller.problems.simple-regression/error-function
|
||||
:max-generations 500
|
||||
:population-size 500
|
||||
:max-initial-plushy-size 100
|
||||
:step-limit 200
|
||||
:parent-selection :lexicase
|
||||
:tournament-size 5
|
||||
:umad-rate 0.1
|
||||
:diploid-flip-rate 0.1
|
||||
:variation {:umad 0.8
|
||||
:diploid-flip 0.2}
|
||||
:elitism false
|
||||
:diploid true})
|
||||
|
||||
|
||||
#_(gp/gp {:instructions propeller.problems.software.smallest/instructions
|
||||
:error-function propeller.problems.software.smallest/error-function
|
||||
:max-generations 500
|
||||
:population-size 500
|
||||
:max-initial-plushy-size 100
|
||||
:step-limit 200
|
||||
:parent-selection :lexicase
|
||||
:tournament-size 5
|
||||
:umad-rate 0.1
|
||||
:diploid-flip-rate 0.1
|
||||
:variation {;:umad 0.8
|
||||
;:diploid-flip 0.2
|
||||
:umad 1
|
||||
}
|
||||
:elitism false
|
||||
:diploid false})
|
||||
|
||||
#_(gp/gp {:instructions propeller.problems.software.smallest/instructions
|
||||
:error-function propeller.problems.software.smallest/error-function
|
||||
:max-generations 500
|
||||
:population-size 500
|
||||
:max-initial-plushy-size 200 ;100
|
||||
:step-limit 200
|
||||
:parent-selection :lexicase
|
||||
:tournament-size 5
|
||||
:umad-rate 0.1
|
||||
:diploid-flip-rate 0.1
|
||||
:variation {:umad 0.8
|
||||
:diploid-flip 0.2
|
||||
;:umad 1
|
||||
}
|
||||
:elitism false
|
||||
:diploid true})
|
||||
|
||||
#_(gp/gp {:instructions propeller.problems.string-classification/instructions
|
||||
:error-function propeller.problems.string-classification/error-function
|
||||
:max-generations 500
|
||||
:population-size 500
|
||||
:max-initial-plushy-size 100
|
||||
:step-limit 200
|
||||
:parent-selection :lexicase
|
||||
:tournament-size 5
|
||||
:umad-rate 0.1
|
||||
:diploid-flip-rate 0.1
|
||||
:variation {:umad 0.8
|
||||
:diploid-flip 0.2
|
||||
}
|
||||
:elitism false
|
||||
:diploid true})
|
||||
;#_(interpreter/interpret-program
|
||||
; '(1 2 :integer_add) state/empty-state 1000)
|
||||
;
|
||||
;#_(interpreter/interpret-program
|
||||
; '(3 3 :integer_eq :exec_if (1 "yes") (2 "no"))
|
||||
; state/empty-state
|
||||
; 1000)
|
||||
;
|
||||
;#_(interpreter/interpret-program
|
||||
; '(:in1 :string_reverse 1 :string_take "?" :string_eq :exec_if
|
||||
; (:in1 " I am asking." :string_concat)
|
||||
; (:in1 " I am saying." :string_concat))
|
||||
; (assoc state/empty-state :input {:in1 "Can you hear me?"})
|
||||
; 1000)
|
||||
;
|
||||
;#_(interpreter/interpret-program
|
||||
; '(:in1 :string_reverse 1 :string_take "?" :string_eq :exec_if
|
||||
; (:in1 " I am asking." :string_concat)
|
||||
; (:in1 " I am saying." :string_concat))
|
||||
; (assoc state/empty-state :input {:in1 "I can hear you."})
|
||||
; 1000)
|
||||
;
|
||||
;#_(genome/plushy->push
|
||||
; (genome/make-random-plushy (get-stack-instructions #{:float :integer :exec :boolean}) 20))
|
||||
;
|
||||
;#_(gp/gp {:instructions propeller.problems.software.number-io/instructions
|
||||
; :error-function propeller.problems.software.number-io/error-function
|
||||
; :max-generations 500
|
||||
; :population-size 500
|
||||
; :max-initial-plushy-size 100
|
||||
; :step-limit 200
|
||||
; :parent-selection :lexicase
|
||||
; :tournament-size 5
|
||||
; :umad-rate 0.1
|
||||
; :variation {:umad 0.5 :crossover 0.5}
|
||||
; :elitism false})
|
||||
;
|
||||
;#_(gp/gp {:instructions propeller.problems.simple-regression/instructions
|
||||
; :error-function propeller.problems.simple-regression/error-function
|
||||
; :max-generations 500
|
||||
; :population-size 500
|
||||
; :max-initial-plushy-size 100
|
||||
; :step-limit 200
|
||||
; :parent-selection :tournament
|
||||
; :tournament-size 5
|
||||
; :umad-rate 0.01
|
||||
; :variation {:umad 1.0
|
||||
; :crossover 0.0}
|
||||
; :elitism false})
|
||||
;
|
||||
;#_(gp/gp {:instructions propeller.problems.simple-regression/instructions
|
||||
; :error-function propeller.problems.simple-regression/error-function
|
||||
; :max-generations 500
|
||||
; :population-size 500
|
||||
; :max-initial-plushy-size 100
|
||||
; :step-limit 200
|
||||
; :parent-selection :tournament
|
||||
; :tournament-size 5
|
||||
; :umad-rate 0.1
|
||||
; :variation {:umad 1.0
|
||||
; :crossover 0.0}
|
||||
; :elitism false})
|
||||
;
|
||||
;
|
||||
;#_(gp/gp {:instructions propeller.problems.simple-regression/instructions
|
||||
; :error-function propeller.problems.simple-regression/error-function
|
||||
; :max-generations 500
|
||||
; :population-size 500
|
||||
; :max-initial-plushy-size 100
|
||||
; :step-limit 200
|
||||
; :parent-selection :lexicase
|
||||
; :tournament-size 5
|
||||
; :umad-rate 0.1
|
||||
; :variation {:umad 1.0
|
||||
; :crossover 0.0}
|
||||
; :elitism false})
|
||||
;
|
||||
;#_(gp/gp {:instructions propeller.problems.simple-regression/instructions
|
||||
; :error-function propeller.problems.simple-regression/error-function
|
||||
; :max-generations 500
|
||||
; :population-size 500
|
||||
; :max-initial-plushy-size 100
|
||||
; :step-limit 200
|
||||
; :parent-selection :lexicase
|
||||
; :tournament-size 5
|
||||
; :umad-rate 0.1
|
||||
; :diploid-flip-rate 0.1
|
||||
; :variation {:umad 0.8
|
||||
; :diploid-flip 0.2}
|
||||
; :elitism false
|
||||
; :diploid true})
|
||||
;
|
||||
;
|
||||
;#_(gp/gp {:instructions propeller.problems.software.smallest/instructions
|
||||
; :error-function propeller.problems.software.smallest/error-function
|
||||
; :max-generations 500
|
||||
; :population-size 500
|
||||
; :max-initial-plushy-size 100
|
||||
; :step-limit 200
|
||||
; :parent-selection :lexicase
|
||||
; :tournament-size 5
|
||||
; :umad-rate 0.1
|
||||
; :diploid-flip-rate 0.1
|
||||
; :variation {;:umad 0.8
|
||||
; ;:diploid-flip 0.2
|
||||
; :umad 1
|
||||
; }
|
||||
; :elitism false
|
||||
; :diploid false})
|
||||
;
|
||||
;#_(gp/gp {:instructions propeller.problems.software.smallest/instructions
|
||||
; :error-function propeller.problems.software.smallest/error-function
|
||||
; :max-generations 500
|
||||
; :population-size 500
|
||||
; :max-initial-plushy-size 200 ;100
|
||||
; :step-limit 200
|
||||
; :parent-selection :lexicase
|
||||
; :tournament-size 5
|
||||
; :umad-rate 0.1
|
||||
; :diploid-flip-rate 0.1
|
||||
; :variation {:umad 0.8
|
||||
; :diploid-flip 0.2
|
||||
; ;:umad 1
|
||||
; }
|
||||
; :elitism false
|
||||
; :diploid true})
|
||||
;
|
||||
;
|
||||
;(gp/gp {:instructions propeller.problems.string-classification/instructions
|
||||
; :error-function propeller.problems.string-classification/error-function
|
||||
; :max-generations 500
|
||||
; :population-size 500
|
||||
; :max-initial-plushy-size 100
|
||||
; :step-limit 200
|
||||
; :parent-selection :lexicase
|
||||
; :tournament-size 5
|
||||
; :umad-rate 0.1
|
||||
; :diploid-flip-rate 0.1
|
||||
; :variation {:umad 0.8
|
||||
; :diploid-flip 0.2
|
||||
; }
|
||||
; :elitism false
|
||||
; :diploid true})
|
||||
|
||||
@ -16,6 +16,20 @@
|
||||
shorter-padded
|
||||
longer))))
|
||||
|
||||
(defn tail-aligned-crossover
|
||||
"Crosses over two individuals using uniform crossover. Pads shorter one on the left."
|
||||
[plushy-a plushy-b]
|
||||
(let [shorter (min-key count plushy-a plushy-b)
|
||||
longer (if (= shorter plushy-a)
|
||||
plushy-b
|
||||
plushy-a)
|
||||
length-diff (- (count longer) (count shorter))
|
||||
shorter-padded (concat (repeat length-diff :crossover-padding) shorter)]
|
||||
(remove #(= % :crossover-padding)
|
||||
(map #(if (< (rand) 0.5) %1 %2)
|
||||
shorter-padded
|
||||
longer))))
|
||||
|
||||
(defn diploid-crossover
|
||||
"Crosses over two individuals using uniform crossover. Pads shorter one."
|
||||
[plushy-a plushy-b]
|
||||
@ -32,6 +46,22 @@
|
||||
shorter-padded
|
||||
longer)))))
|
||||
|
||||
(defn tail-aligned-diploid-crossover
|
||||
"Crosses over two individuals using uniform crossover. Pads shorter one on the left."
|
||||
[plushy-a plushy-b]
|
||||
(let [plushy-a (partition 2 plushy-a)
|
||||
plushy-b (partition 2 plushy-b)
|
||||
shorter (min-key count plushy-a plushy-b)
|
||||
longer (if (= shorter plushy-a)
|
||||
plushy-b
|
||||
plushy-a)
|
||||
length-diff (- (count longer) (count shorter))
|
||||
shorter-padded (concat (repeat length-diff :crossover-padding) shorter)]
|
||||
(flatten (remove #(= % :crossover-padding)
|
||||
(map #(if (< (rand) 0.5) %1 %2)
|
||||
shorter-padded
|
||||
longer)))))
|
||||
|
||||
(defn uniform-addition
|
||||
"Returns plushy with new instructions possibly added before or after each
|
||||
existing instruction."
|
||||
@ -51,6 +81,16 @@
|
||||
%)
|
||||
plushy))
|
||||
|
||||
(defn diploid-uniform-silent-replacement
|
||||
"Returns plushy with new instructions possibly replacing existing
|
||||
instructions, but only among the silent member of each pair."
|
||||
[plushy instructions replacement-rate]
|
||||
(interleave (map first (partition 2 plushy))
|
||||
(map #(if (< (rand) replacement-rate)
|
||||
(utils/random-instruction instructions)
|
||||
%)
|
||||
(map second (partition 2 plushy)))))
|
||||
|
||||
(defn diploid-uniform-addition
|
||||
"Returns plushy with new instructions possibly added before or after each
|
||||
existing instruction."
|
||||
@ -105,6 +145,11 @@
|
||||
(:plushy (selection/select-parent pop argmap))
|
||||
(:plushy (selection/select-parent pop argmap)))
|
||||
;
|
||||
:tail-aligned-crossover
|
||||
(tail-aligned-crossover
|
||||
(:plushy (selection/select-parent pop argmap))
|
||||
(:plushy (selection/select-parent pop argmap)))
|
||||
;
|
||||
:umad
|
||||
(-> (:plushy (selection/select-parent pop argmap))
|
||||
(uniform-addition (:instructions argmap) (:umad-rate argmap))
|
||||
@ -118,6 +163,10 @@
|
||||
(-> (:plushy (selection/select-parent pop argmap))
|
||||
(uniform-replacement (:instructions argmap) (:replacement-rate argmap)))
|
||||
;
|
||||
:diploid-uniform-silent-replacement
|
||||
(-> (:plushy (selection/select-parent pop argmap))
|
||||
(diploid-uniform-silent-replacement (:instructions argmap) (:replacement-rate argmap)))
|
||||
;
|
||||
:uniform-deletion
|
||||
(-> (:plushy (selection/select-parent pop argmap))
|
||||
(uniform-deletion (:umad-rate argmap)))
|
||||
@ -127,6 +176,11 @@
|
||||
(:plushy (selection/select-parent pop argmap))
|
||||
(:plushy (selection/select-parent pop argmap)))
|
||||
;
|
||||
:tail-aligned-diploid-crossover
|
||||
(tail-aligned-diploid-crossover
|
||||
(:plushy (selection/select-parent pop argmap))
|
||||
(:plushy (selection/select-parent pop argmap)))
|
||||
;
|
||||
:diploid-umad
|
||||
(-> (:plushy (selection/select-parent pop argmap))
|
||||
(diploid-uniform-addition (:instructions argmap) (:umad-rate argmap))
|
||||
|
||||
@ -1,7 +0,0 @@
|
||||
(ns propeller.core-test
|
||||
(:require [clojure.test :refer :all]
|
||||
[propeller.core :refer :all]))
|
||||
|
||||
(deftest a-test
|
||||
(testing "FIXME, I fail."
|
||||
(is (= 0 1))))
|
||||
475
test/propeller/push/instructions/vector_spec.clj
Normal file
475
test/propeller/push/instructions/vector_spec.clj
Normal file
@ -0,0 +1,475 @@
|
||||
(ns propeller.push.instructions.vector-spec
|
||||
(:require
|
||||
[clojure.test.check.generators :as gen]
|
||||
[clojure.test.check.properties :as prop]
|
||||
[clojure.test.check.clojure-test :as ct :refer [defspec]]
|
||||
[propeller.push.state :as state]
|
||||
[propeller.push.instructions.vector :as vector]
|
||||
[propeller.push.interpreter :as interpreter]))
|
||||
|
||||
(def gen-type-pairs
|
||||
[['gen/small-integer "integer"]
|
||||
['gen/double "float"]
|
||||
['gen/boolean "boolean"]
|
||||
['gen/string "string"]])
|
||||
|
||||
(defn generator-for-arg-type
|
||||
[arg-type generator]
|
||||
(case arg-type
|
||||
:boolean 'gen/boolean
|
||||
:integer 'gen/small-integer
|
||||
:float 'gen/double
|
||||
:string 'gen/string
|
||||
; This is for "generic" vectors where the element is provided by
|
||||
; the `generator` argument.
|
||||
:vector `(gen/vector ~generator)
|
||||
:item generator
|
||||
:vector_boolean '(gen/vector gen/boolean)
|
||||
:vector_integer '(gen/vector gen/small-integer)
|
||||
:vector_float '(gen/vector gen/double)
|
||||
:vector_string '(gen/vector gen/string)))
|
||||
|
||||
(defmacro gen-specs
|
||||
[spec-name check-fn & arg-types]
|
||||
(let [symbol-names (repeatedly (count arg-types) gensym)]
|
||||
`(do ~@(for [[generator value-type] gen-type-pairs
|
||||
:let [name (symbol (str spec-name "-spec-" value-type))]]
|
||||
`(defspec ~name
|
||||
(prop/for-all
|
||||
[~@(mapcat
|
||||
(fn [symbol-name arg-type]
|
||||
[symbol-name (generator-for-arg-type arg-type generator)])
|
||||
symbol-names
|
||||
arg-types)]
|
||||
(~check-fn ~value-type ~@symbol-names)))))))
|
||||
|
||||
;;; vector/_butlast
|
||||
|
||||
(defn check-butlast
|
||||
[value-type vect]
|
||||
(let [stack-type (keyword (str "vector_" value-type))
|
||||
start-state (state/push-to-stack state/empty-state
|
||||
stack-type
|
||||
vect)
|
||||
end-state (vector/_butlast stack-type start-state)
|
||||
expected-result (vec (butlast vect))]
|
||||
(= expected-result
|
||||
(state/peek-stack end-state stack-type))))
|
||||
|
||||
(gen-specs "butlast" check-butlast :vector)
|
||||
|
||||
;;; vector/_concat
|
||||
|
||||
(defn check-concat
|
||||
"Creates an otherwise empty Push state with the two given vectors on the
|
||||
appropriate vector stack (assumed to be :vector_<value-type>).
|
||||
It then runs the vector/_concat instruction, and confirms that the
|
||||
result (on the :vector_<value-type> stack) is the expected value.
|
||||
The order of concatenation is that the top of the stack will be
|
||||
_second_ in the concatenation, i.e., its elements will come _after_
|
||||
the elements in the vector one below it in the stack."
|
||||
[value-type first-vect second-vect]
|
||||
(let [stack-type (keyword (str "vector_" value-type))
|
||||
start-state (state/push-to-stack
|
||||
(state/push-to-stack state/empty-state
|
||||
stack-type
|
||||
first-vect)
|
||||
stack-type second-vect)
|
||||
end-state (vector/_concat stack-type start-state)]
|
||||
(= (concat second-vect first-vect)
|
||||
(state/peek-stack end-state stack-type))))
|
||||
|
||||
(gen-specs "concat" check-concat :vector :vector)
|
||||
|
||||
;;; vecotr/_conj
|
||||
|
||||
(defn check-conj
|
||||
[value-type vect value]
|
||||
(let [stack-type (keyword (str "vector_" value-type))
|
||||
start-state (state/push-to-stack
|
||||
(state/push-to-stack state/empty-state
|
||||
stack-type
|
||||
vect)
|
||||
(keyword (str value-type))
|
||||
value)
|
||||
end-state (vector/_conj stack-type start-state)
|
||||
expected-result (conj vect value)]
|
||||
(= expected-result
|
||||
(state/peek-stack end-state stack-type))))
|
||||
|
||||
(gen-specs "conj" check-conj :vector :item)
|
||||
|
||||
;;; vector/_contains
|
||||
|
||||
(defn check-contains
|
||||
"Creates an otherwise empty Push state with the given vector on the
|
||||
appropriate vector stack (assumed to be :vector_<value-type>), and
|
||||
the given value on the appropriate stack (determined by value-type).
|
||||
It then runs the vector/_contains instruction, and confirms that the
|
||||
result (on the :boolean stack) is the expected value."
|
||||
[value-type vect value]
|
||||
(let [stack-type (keyword (str "vector_" value-type))
|
||||
start-state (state/push-to-stack
|
||||
(state/push-to-stack state/empty-state
|
||||
stack-type
|
||||
vect)
|
||||
(keyword value-type) value)
|
||||
end-state (vector/_contains stack-type start-state)
|
||||
expected-result (not= (.indexOf vect value) -1)]
|
||||
(= expected-result
|
||||
(state/peek-stack end-state :boolean))))
|
||||
|
||||
(gen-specs "contains" check-contains :vector :item)
|
||||
|
||||
;;; vector/_emptyvector
|
||||
|
||||
(defn check-empty-vector
|
||||
[value-type vect]
|
||||
(let [stack-type (keyword (str "vector_" value-type))
|
||||
start-state (state/push-to-stack state/empty-state
|
||||
stack-type
|
||||
vect)
|
||||
end-state (vector/_emptyvector stack-type start-state)]
|
||||
(= (empty? vect)
|
||||
(state/peek-stack end-state :boolean))))
|
||||
|
||||
(gen-specs "empty-vector" check-empty-vector :vector)
|
||||
|
||||
;;; vector/_first
|
||||
|
||||
(defn check-first
|
||||
[value-type vect]
|
||||
(let [stack-type (keyword (str "vector_" value-type))
|
||||
start-state (state/push-to-stack state/empty-state
|
||||
stack-type
|
||||
vect)
|
||||
end-state (vector/_first stack-type start-state)]
|
||||
(or
|
||||
(and (empty? vect)
|
||||
(= (state/peek-stack end-state stack-type)
|
||||
vect))
|
||||
(and
|
||||
(= (first vect)
|
||||
(state/peek-stack end-state (keyword value-type)))
|
||||
(state/empty-stack? end-state stack-type)))))
|
||||
|
||||
(gen-specs "first" check-first :vector)
|
||||
|
||||
;;; vector/_indexof
|
||||
|
||||
(defn check-indexof
|
||||
"Creates an otherwise empty Push state with the given vector on the
|
||||
appropriate vector stack (assumed to be :vector_<value-type>), and
|
||||
the given value on the appropriate stack (determined by value-type).
|
||||
It then runs the vector/_indexof instruction, and confirms that the
|
||||
result (on the :integer stack) is the expected value."
|
||||
[value-type vect value]
|
||||
(let [stack-type (keyword (str "vector_" value-type))
|
||||
start-state (state/push-to-stack
|
||||
(state/push-to-stack state/empty-state
|
||||
stack-type
|
||||
vect)
|
||||
(keyword value-type) value)
|
||||
end-state (vector/_indexof stack-type start-state)
|
||||
expected-index (.indexOf vect value)]
|
||||
(= expected-index
|
||||
(state/peek-stack end-state :integer))))
|
||||
|
||||
(gen-specs "indexof" check-indexof :vector :item)
|
||||
|
||||
;;; vector/_iterate
|
||||
|
||||
(defn check-iterate
|
||||
[value-type vect]
|
||||
(let [stack-type (keyword (str "vector_" value-type))
|
||||
print-instr (keyword (str value-type "_print"))
|
||||
iter-instr (keyword (str "vector_" value-type "_iterate"))
|
||||
program [iter-instr print-instr]
|
||||
start-state (-> state/empty-state
|
||||
(state/push-to-stack stack-type vect)
|
||||
(state/push-to-stack :output ""))
|
||||
; 4 times the vector length should be enough for this iteration, perhaps even
|
||||
; more than we strictly need.
|
||||
end-state (interpreter/interpret-program program start-state (* 4 (count vect)))
|
||||
; pr-str adds escaped quote marks, which causes tests to fail because _print
|
||||
; treats strings and characters specially and does not call pr-str on them.
|
||||
to-str-fn (if (= value-type "string") identity pr-str)
|
||||
expected-result (apply str (map to-str-fn vect))]
|
||||
(= expected-result
|
||||
(state/peek-stack end-state :output))))
|
||||
|
||||
(gen-specs "iterate" check-iterate :vector)
|
||||
|
||||
;;; vector/_last
|
||||
|
||||
(defn check-last
|
||||
[value-type vect]
|
||||
(let [stack-type (keyword (str "vector_" value-type))
|
||||
start-state (state/push-to-stack state/empty-state
|
||||
stack-type
|
||||
vect)
|
||||
end-state (vector/_last stack-type start-state)]
|
||||
(or
|
||||
(and (empty? vect)
|
||||
(= (state/peek-stack end-state stack-type)
|
||||
vect))
|
||||
(and
|
||||
(= (last vect)
|
||||
(state/peek-stack end-state (keyword value-type)))
|
||||
(state/empty-stack? end-state stack-type)))))
|
||||
|
||||
(gen-specs "last" check-last :vector)
|
||||
|
||||
;;; vector/_length
|
||||
|
||||
(defn check-length
|
||||
[value-type vect]
|
||||
(let [stack-type (keyword (str "vector_" value-type))
|
||||
start-state (state/push-to-stack state/empty-state
|
||||
stack-type
|
||||
vect)
|
||||
end-state (vector/_length stack-type start-state)
|
||||
expected-result (count vect)]
|
||||
(= expected-result
|
||||
(state/peek-stack end-state :integer))))
|
||||
|
||||
(gen-specs "length" check-length :vector)
|
||||
|
||||
;;; vector/_nth
|
||||
|
||||
(defn check-nth
|
||||
[value-type vect n]
|
||||
(let [stack-type (keyword (str "vector_" value-type))
|
||||
start-state (state/push-to-stack
|
||||
(state/push-to-stack state/empty-state
|
||||
stack-type
|
||||
vect)
|
||||
:integer
|
||||
n)
|
||||
end-state (vector/_nth stack-type start-state)]
|
||||
(or
|
||||
(and (empty? vect)
|
||||
(= (state/peek-stack end-state stack-type)
|
||||
vect))
|
||||
(and
|
||||
(= (get vect (mod n (count vect)))
|
||||
(state/peek-stack end-state (keyword value-type)))))))
|
||||
|
||||
(gen-specs "nth" check-nth :vector :integer)
|
||||
|
||||
;;; vector/_occurrencesof
|
||||
|
||||
(defn check-occurrencesof
|
||||
[value-type vect value]
|
||||
(let [stack-type (keyword (str "vector_" value-type))
|
||||
start-state (state/push-to-stack
|
||||
(state/push-to-stack state/empty-state
|
||||
stack-type
|
||||
vect)
|
||||
(keyword value-type)
|
||||
value)
|
||||
end-state (vector/_occurrencesof stack-type start-state)
|
||||
expected-result (count (filterv #(= value %) vect))]
|
||||
(= expected-result
|
||||
(state/peek-stack end-state :integer))))
|
||||
|
||||
(gen-specs "occurrencesof" check-occurrencesof :vector :item)
|
||||
|
||||
;;; vector/_pushall
|
||||
|
||||
(defn check-pushall
|
||||
[value-type vect]
|
||||
(let [stack-type (keyword (str "vector_" value-type))
|
||||
start-state (state/push-to-stack state/empty-state
|
||||
stack-type
|
||||
vect)
|
||||
end-state (vector/_pushall stack-type start-state)
|
||||
value-stack (keyword value-type)
|
||||
vect-length (count vect)]
|
||||
(and
|
||||
(=
|
||||
(vec (state/peek-stack-many end-state value-stack vect-length))
|
||||
vect)
|
||||
(state/empty-stack?
|
||||
(state/pop-stack-many end-state value-stack vect-length)
|
||||
value-stack))))
|
||||
|
||||
(gen-specs "pushall" check-pushall :vector)
|
||||
|
||||
;;; vector/_remove
|
||||
|
||||
(defn check-remove
|
||||
[value-type vect value]
|
||||
(let [stack-type (keyword (str "vector_" value-type))
|
||||
start-state (state/push-to-stack
|
||||
(state/push-to-stack state/empty-state
|
||||
stack-type
|
||||
vect)
|
||||
(keyword value-type)
|
||||
value)
|
||||
end-state (vector/_remove stack-type start-state)]
|
||||
(= []
|
||||
(filterv #(= % value) (state/peek-stack end-state stack-type)))))
|
||||
|
||||
(gen-specs "remove" check-remove :vector :item)
|
||||
|
||||
;;; vector/_replace
|
||||
|
||||
(defn check-replace
|
||||
[value-type vect toreplace replacement]
|
||||
(let [stack-type (keyword (str "vector_" value-type))
|
||||
value-stack (keyword value-type)
|
||||
start-state (state/push-to-stack
|
||||
(state/push-to-stack
|
||||
(state/push-to-stack state/empty-state
|
||||
stack-type
|
||||
vect)
|
||||
value-stack
|
||||
toreplace)
|
||||
value-stack
|
||||
replacement)
|
||||
end-state (vector/_replace stack-type start-state)
|
||||
expected-result (replace {toreplace replacement} vect)]
|
||||
(= expected-result
|
||||
(state/peek-stack end-state stack-type))))
|
||||
|
||||
(gen-specs "replace" check-replace :vector :item :item)
|
||||
|
||||
;;; vector/_replacefirst
|
||||
|
||||
(defn check-replacefirst
|
||||
[value-type vect toreplace replacement]
|
||||
(let [stack-type (keyword (str "vector_" value-type))
|
||||
value-stack (keyword value-type)
|
||||
start-state (state/push-to-stack
|
||||
(state/push-to-stack
|
||||
(state/push-to-stack state/empty-state
|
||||
stack-type
|
||||
vect)
|
||||
value-stack
|
||||
toreplace)
|
||||
value-stack
|
||||
replacement)
|
||||
end-state (vector/_replacefirst stack-type start-state)
|
||||
end-vector (state/peek-stack end-state stack-type)
|
||||
replacement-index (.indexOf vect toreplace)]
|
||||
(or
|
||||
(and (= replacement-index -1)
|
||||
(state/empty-stack? end-state value-stack)
|
||||
(= vect end-vector))
|
||||
(and (state/empty-stack? end-state value-stack)
|
||||
(= end-vector (assoc vect replacement-index replacement))))))
|
||||
|
||||
(gen-specs "replacefirst" check-replacefirst :vector :item :item)
|
||||
|
||||
;;; vector/_rest
|
||||
|
||||
(defn check-rest
|
||||
[value-type vect]
|
||||
(let [stack-type (keyword (str "vector_" value-type))
|
||||
start-state (state/push-to-stack state/empty-state
|
||||
stack-type
|
||||
vect)
|
||||
end-state (vector/_rest stack-type start-state)
|
||||
expected-result (vec (rest vect))]
|
||||
(= expected-result
|
||||
(state/peek-stack end-state stack-type))))
|
||||
|
||||
(gen-specs "rest" check-rest :vector)
|
||||
|
||||
;;; vector/_reverse
|
||||
|
||||
(defn check-reverse
|
||||
[value-type vect]
|
||||
(let [stack-type (keyword (str "vector_" value-type))
|
||||
start-state (state/push-to-stack state/empty-state
|
||||
stack-type
|
||||
vect)
|
||||
end-state (vector/_reverse stack-type start-state)
|
||||
expected-result (vec (reverse vect))]
|
||||
(= expected-result
|
||||
(state/peek-stack end-state stack-type))))
|
||||
|
||||
(gen-specs "reverse" check-reverse :vector)
|
||||
|
||||
;;; vector/_set
|
||||
|
||||
(defn check-set
|
||||
[value-type vect value n]
|
||||
(let [stack-type (keyword (str "vector_" value-type))
|
||||
value-stack (keyword value-type)
|
||||
start-state (state/push-to-stack
|
||||
(state/push-to-stack
|
||||
(state/push-to-stack state/empty-state
|
||||
stack-type
|
||||
vect)
|
||||
value-stack
|
||||
value)
|
||||
:integer
|
||||
n)
|
||||
end-state (vector/_set stack-type start-state)]
|
||||
(or
|
||||
(and
|
||||
(empty? vect)
|
||||
(not (state/empty-stack? end-state :integer))
|
||||
(not (state/empty-stack? end-state value-stack))
|
||||
(= vect (state/peek-stack end-state stack-type)))
|
||||
(and
|
||||
(= (state/peek-stack end-state stack-type)
|
||||
(assoc vect (mod n (count vect)) value))
|
||||
(state/empty-stack? end-state :integer)
|
||||
(state/empty-stack? end-state value-stack)))))
|
||||
|
||||
(gen-specs "set" check-set :vector :item :integer)
|
||||
|
||||
;;; vector/_subvec
|
||||
|
||||
(defn clean-subvec-bounds
|
||||
[start stop vect-size]
|
||||
(let [start (max 0 start)
|
||||
stop (max 0 stop)
|
||||
start (min start vect-size)
|
||||
stop (min stop vect-size)
|
||||
stop (max start stop)]
|
||||
[start stop]))
|
||||
|
||||
(defn check-subvec
|
||||
"Creates an otherwise empty Push state with the given vector on the
|
||||
appropriate vector stack (assumed to be :vector_<value-type>), and
|
||||
the given values on the integer stack.
|
||||
It then runs the vector/_subvec instruction, and confirms that the
|
||||
result (on the :vector_<value-type> stack) is the expected value."
|
||||
[value-type vect start stop]
|
||||
(let [stack-type (keyword (str "vector_" value-type))
|
||||
start-state (state/push-to-stack
|
||||
(state/push-to-stack
|
||||
(state/push-to-stack state/empty-state
|
||||
stack-type
|
||||
vect)
|
||||
:integer start)
|
||||
:integer stop)
|
||||
end-state (vector/_subvec stack-type start-state)
|
||||
[cleaned-start cleaned-stop] (clean-subvec-bounds start stop (count vect))
|
||||
expected-subvec (subvec vect cleaned-start cleaned-stop)]
|
||||
(= expected-subvec
|
||||
(state/peek-stack end-state stack-type))))
|
||||
|
||||
(gen-specs "subvec" check-subvec :vector :integer :integer)
|
||||
|
||||
;;; vector/_take
|
||||
|
||||
(defn check-take
|
||||
[value-type vect n]
|
||||
(let [stack-type (keyword (str "vector_" value-type))
|
||||
start-state (state/push-to-stack
|
||||
(state/push-to-stack state/empty-state
|
||||
stack-type
|
||||
vect)
|
||||
:integer
|
||||
n)
|
||||
end-state (vector/_take stack-type start-state)
|
||||
expected-result (vec (take n vect))]
|
||||
(= expected-result
|
||||
(state/peek-stack end-state stack-type))))
|
||||
|
||||
(gen-specs "take" check-take :vector :integer)
|
||||
Loading…
x
Reference in New Issue
Block a user