gen-stacc

[AM]

could be interesting for you... an really extend gen-stacc-function 

greetings

andré

 

;;; SUB

(defun center-position-in-list (list &key (get-value 'nil))
  (let ((pos))
    (progn
      (setf pos (if (evenp (length list))
                  (/ (length list) 2)
                  (/ (1+ (length list)) 2)))
      (if (equal get-value 'nil)
        (append pos)
        (nth (1- pos) list)))))


;(center-position-in-list '(1 2 3 4 x 4 3 2 1) :get-value nil)
;(center-position-in-list '(1 2 3 4 x 4 3 2 1) :get-value t)


(defun gen-stacc3 (n-liste liste &key (stacc-chance 1))
  (loop for i in liste
    with n
    do (setq n (rnd-pick* n-liste))
    when (and (> i n) (equal (weighted-t/nil stacc-chance) 't))
    append (list n (* -1 (- (abs i) n)))
    else collect i))

;(gen-stacc3 '(1/2) '(3 4 5 3 2 1) :stacc-chance 0.5)
;(gen-stacc3 '(1/32 3/32) '(3/32 5/32  14/8) :stacc-chance 0.5)


;;; MAIN

(defun gen-stacc* (liste &key 
                         (symmetrical 'nil) 
                         (stacc-chance 1) 
                         (possible-stacc-lengths 'nil)
                         (no-center-stacc 'nil))
  (let ((alist liste) (blist) (val)
        (n (/ 1 (find-max (mapcar 'denominator liste)))))

    (if (equal symmetrical 'nil)
      ;;bei unsymmetrischen strukturen
      (gen-stacc3 (if (equal possible-stacc-lengths 'nil) 
                    (list n)
                    possible-stacc-lengths)
                    liste :stacc-chance stacc-chance)
      ;;bei symmetrischen strukturen
      (if (evenp (length liste))
        (progn 
          (setf alist (gen-stacc3 (if (equal possible-stacc-lengths 'nil) 
                                    (list n)
                                    possible-stacc-lengths) 
                                  (filter-first (/ (length liste) 2) liste)
                                  :stacc-chance stacc-chance))

          (setf blist (flatten (loop for i in (reverse (gen-divide 2 alist))
                                 collect (reverse i))))
          (append alist blist))
        
        (progn 
          (setf alist (gen-stacc3 (if (equal possible-stacc-lengths 'nil) 
                                    (list n)
                                    possible-stacc-lengths)
                                  (filter-first (/ (1- (length liste)) 2) liste)
                                  :stacc-chance stacc-chance))
          (setf blist (flatten (loop for i in (reverse (gen-divide 2 alist))
                                 collect (reverse i))))
          (append alist 
                  (if (equal no-center-stacc 't)
                    (list (center-position-in-list liste :get-value t))
                    (progn 
                      (setf val (/ (center-position-in-list liste :get-value t) 3))
                      (list (* -1 val) val (* -1 val))))
                  blist))))))


;; ordinario
(gen-stacc* (gen-length '(4 5 6 3 6 5 4) 1/20)) 

;; vorgebener stacc-wert
(gen-stacc* '(4 5 6 3 6 5 4) 
            :possible-stacc-lengths '(1/4))


;; wählt rnd die längen der stacc-values
(gen-stacc* '(4 5 6 3 6 5 4) 
            :possible-stacc-lengths '(2/32 1/32 5/32 1/4))

;; rnd-stacc
(gen-stacc* (gen-length '(4 5 6 3 6 5 4) 1/32) 
            :stacc-chance 0.4)

;; rnd-stacc mit verschiedenen möglichen stacc-lengths
(gen-stacc* (gen-length '(4 5 6 3 6 5 4) 1/32) 
            :stacc-chance 0.7
            :possible-stacc-lengths '(2/32 1/32))

;; symm-strukturen werden berücksichtigt
(gen-stacc* (gen-length '(4 5 6 7 6 5 4) 1/32) 
            :symmetrical t
            :no-center-stacc t)

;; ohne stacc bei center-value
(gen-stacc* (gen-length '(4 5 6 7 6 5 4) 1/32) 
            :symmetrical t
            :no-center-stacc t)