extended gen-symmetrical*

[AM]

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)