Jump to content

Featured Replies

Posted

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)

 

Create an account or sign in to comment


Copyright © 2014-2025 Opusmodus™ Ltd. All rights reserved.
Product features, specifications, system requirements and availability are subject to change without notice.
Opusmodus, the Opusmodus logo, and other Opusmodus trademarks are either registered trademarks or trademarks of Opusmodus Ltd.
All other trademarks contained herein are the property of their respective owners.

Powered by Invision Community

Important Information

Terms of Use Privacy Policy