AM Posted May 5, 2017 Share Posted May 5, 2017 some extensions to the basic function... greetings andré ;;; SUB (defun rnd-pick* (alist) (if (and (listp (first alist)) (floatp (second (first alist)))) (weighted-random alist) (rnd-pick alist))) (defun weighted-random (list) (loop for item in list with rand-num = (random (loop for x in list sum (second x))) for add = (second item) then (+ add (second item)) when (< rand-num add) return (first item))) ;;; MAIN (defun gen-symmetrical* (n list &key (type 'nil)) (if (equal type 'hierarchic) (progn (let ((alist (butlast list)) (center (last list))) (if (> n (* 2 (length list))) 'list-has-too-few-items (if (evenp n) (progn (setf alist (loop repeat (/ n 2) for i in alist collect (rnd-pick* i))) (append alist (reverse alist))) (progn (setf alist (loop repeat (/ (1- n) 2) for i in alist collect (rnd-pick* i))) (append alist (list (rnd-pick* (flatten center))) (reverse alist))))))) (progn (let ((list (rnd-order list)) (newlist (rest list)) (center (car list))) (if (> n (* 2 (length list))) 'list-has-too-few-items (if (evenp n) (progn (setf list (rnd-unique (/ n 2) newlist)) (append list (reverse list))) (progn (setf list (rnd-unique (/ (1- n) 2) (rest newlist))) (append list (list center) (reverse list))))))))) ;;ordinario (gen-symmetrical* 5 '(1 2 3 4 5 6 7 8)) ;;unmittelbare wiederholungen möglich (gen-symmetrical* 9 '(1 2 3 4 5 6 7 8) :repeat t) ;;werte kommen nur doppelt vor durch die symmetrie- ;;bildung, aber nicht auf einer der symmetrieseiten. (gen-symmetrical* 9 '(1 2 3 4 5 6 7 8) :style 'unique) (gen-symmetrical* 30 '(1 2 3 4 5 6 7 8) :style 'unique) ;;=> list-has-too-few-items ;;bei ":type 'hierarchic" wird immer zuerst aus der ;;ersten sublist ausgewählt, dann aus der zweiten etc... (gen-symmetrical* 6 '((a b c) (6 7) (8 9) (10 11)) :style 'unique :type 'hierarchic) ;;auch mit weight möglich (gen-symmetrical* 5 '(((1 0.2) (2 0.8)) ((4 0.1) (5 0.9)) (6 7) (8 9) (10 11)) :style 'unique :type 'hierarchic) opmo 1 Quote Link to comment Share on other sites More sharing options...
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.