SHOW:
|
|
- or go back to the newest paste.
| 1 | #lang racket | |
| 2 | (define-namespace-anchor anc) | |
| 3 | (define ns (namespace-anchor->namespace anc)) | |
| 4 | (define (char->symbol c) (string->symbol (string c))) | |
| 5 | (define (nvector . vars) (apply list vars)) | |
| 6 | (define (interval low high) (cons low high)) | |
| 7 | (define (inrange range) (+ (car range) (random (- (cdr range) (car range))))) | |
| 8 | (define (particle pos velocity) (cons pos velocity)) | |
| 9 | (define (newparticle ranges) (particle (map (lambda (range) (inrange range)) ranges) (map (lambda (range) (* .1 (inrange range))) ranges))) | |
| 10 | (define (newcandidate ranges) (candidate (map (lambda (range) (inrange range)) ranges) (map (lambda (range) (* .1 (inrange range))) ranges) #f)) | |
| 11 | (define maximise #t) (define minimise #f) | |
| 12 | (define (candidate pos velocity best) (cons (particle pos velocity) best)) | |
| 13 | ||
| 14 | ||
| 15 | (define (newpopulation populationsize ranges) (map (lambda (x) (newcandidate ranges)) (range populationsize))) | |
| 16 | ||
| 17 | (define (iteratecandidate c globalextreme) (let ((localextreme (cdr candidate))) (candidate globalextreme))) | |
| 18 | (define (applyparticle p f) (apply f (car p))) | |
| 19 | ||
| 20 | (define (ratecandidate c f) (applyparticle (car c) f)) | |
| 21 | ||
| 22 | (define (best pop currentextreme direction) (if (null? pop) currentextreme (if (< (cadr (car pop)) (car currentextreme)) (best (cdr pop) (cdar pop) direction) (best (cdr pop) currentextreme direction) ))) | |
| 23 | (define (stepcandidatepos p v) (if (null? p) '() (cons (+ (car v) (car p)) (stepcandidatepos (cdr p) (cdr v))))) | |
| 24 | ||
| 25 | (define (stepcandidatevelocity p v ge le) (if (null? v) '() (cons (+ (* (car v) .9) (* .01 (- (car ge) (car p))) (* .01 (- (car le) (car p)))) (stepcandidatevelocity (cdr p) (cdr v) (cdr ge) (cdr le))))) | |
| 26 | ||
| 27 | (define (stepcandidate c ge) (candidate (stepcandidatepos (caar c) (cdar c)) (stepcandidatevelocity (caar c) (cdar c) (cdr ge) (cddr c)) (cdr c))) | |
| 28 | ||
| 29 | (define (movepop pop globalextreme) (map (lambda (a) (stepcandidate a globalextreme)) pop)) | |
| 30 | ||
| 31 | (define (iteratepopulation candidates f globalextreme direction n) | |
| 32 | (if (= 0 n) candidates | |
| 33 | (let ((fitnesses (map (lambda (x) ((lambda (y) (candidate (caar x) (cdar x) (cons y (caar x)))) (ratecandidate x f))) candidates))) | |
| 34 | (let ((GE (best fitnesses globalextreme direction))) | |
| 35 | (iteratepopulation (movepop fitnesses globalextreme) f GE direction (- n 1)))))) | |
| 36 | ||
| 37 | (define (varnames n) (map (lambda (x) (char->symbol (integer->char (+ 97 x)))) (range n))) | |
| 38 | ||
| 39 | (define (controlnames n) (map (lambda (x) (string->symbol (string-append "c" (format "~v" x)))) (range n))) | |
| 40 | ||
| 41 | (define mypop | |
| 42 | (iteratepopulation (newpopulation 30 (list (interval -100 100) (interval -100 100) (interval -100 100))) (lambda (a b c) (abs (- 420 (+ a (* a (- b c)) c (* c a))))) '(99999 0 0 0) minimise 300) ) | |
| 43 | ||
| 44 | (define-syntax-rule (funcify inps val) | |
| 45 | `(lambda ,inps ,val)) | |
| 46 | ||
| 47 | (define-syntax-rule (difference a b) `(abs (- ,a ,b))) | |
| 48 | ||
| 49 | (define-syntax-rule (a=b a b varcount) (funcify (varnames varcount) (difference a b))) | |
| 50 | ||
| 51 | (define-syntax-rule (quickPSO f vars direction) | |
| 52 | (best (iteratepopulation (newpopulation 30 (map (lambda (x) (interval -100 100)) (range vars))) (eval f ns) '(99999 0 0 0 0 0 0 0 0) direction 300) '(99999 0 0 0 0 0 0 0 0) minimise)) | |
| 53 | ||
| 54 | (define (listdifference a b) (if (null? a) 0 (+ (expt (abs (- (car a) (car b))) .5) (listdifference (cdr a) (cdr b))))) | |
| 55 | ||
| 56 | (define-syntax-rule (IOmatch trainingset f) | |
| 57 | (let ((inputvars (if (list? (caar trainingset)) (length (caar trainingset)) 1)) | |
| 58 | (outputvars (if (list? (cdar trainingset)) (length (cdar trainingset)) 1))) | |
| 59 | (quickPSO (funcify (varnames 8) `(listdifference (map (lambda ,(controlnames inputvars) f) ',(map car trainingset)) ',(map cdr trainingset))) 8 minimise) | |
| 60 | )) | |
| 61 | ||
| 62 | - | " |
| 62 | + | (IOmatch |
| 63 | - | (quickPSO (a=b '(+ a b) '(+ (* .5 a b) a (* 3 b)) 2) 2 minimise) |
| 63 | + | '((0 . 0) |
| 64 | (1 . 1) | |
| 65 | - | " |
| 65 | + | (2 . 1) |
| 66 | (3 . 2) | |
| 67 | (4 . 3) | |
| 68 | (5 . 5) | |
| 69 | (6 . 8)) | |
| 70 | (+ a c0)) 8 minimise) |