Jump to content

AM

Members
 View Profile  See their activity

  • Posts

    792

  • Joined

  • Last visited

 Content Type 

Posts posted by AM

    read-list-in-steps -> another idea to code this?

    in User Extensions Source Code

    Posted · Edited by AM
    small code correction

    great... that's a smart solution :-) simpler then mine

    ...i didn't know how to set "-1" outside the FUNCTION without DEFSTRUCT

    thanx!!

     

    i like it when the program tells me that it has done the job... so i coded a little extension: 

    (let ((i -1))
  (defun next (liste &key (stop 'nil) (one-cycle 'nil)) 
    (if (equal stop 't)
      (if (< i (1- (length liste)))
        (nth (mod (incf i) (length liste)) liste)
        (if (equal one-cycle 'nil)
          (progn 
            (setf i -1)
            'nil)
          'nil))
      (nth (mod (incf i) (length liste)) liste))))
        

(next '(a b c d e f))
(next '(a b c d e f) :stop t :one-cycle nil) ;; shows a NIL after last value, then starts again
(next '(a b c d e f) :stop t :one-cycle t) ;; shwows only NILs after the last value

     

    read-list-in-steps -> another idea to code this?

    in User Extensions Source Code

    Posted

    is there another way to code such a function/idea?

    this is (at the moment) a "theoretically function"... no concret use - l'art pour l'art :-)

    thanx for smarter LISP-code-IDEAS!

    andré

      

    ;;; evaluate PROGN (as a reset)

(progn
  (defstruct counter n)
  (defvar cnt)
  (setf cnt (make-counter :n -1))
  (defun read-list-in-steps (alist)
    (nth (setf (counter-n cnt) (1+ (counter-n cnt))) alist)))

;;; evaluate a view times, so one value after the other will be in the output
;;; you have to evaluate the progn-seq before every new start!!!

(read-list-in-steps '(1 2 3 4 5 6))
(read-list-in-steps '(c4 f4 e4 f4 g5))

     

    flexible rnd-pick function

    in User Extensions Source Code

    Posted

    a "rnd-pick" that works with different "input-formats"... so it's flexible to use... for many (not all) input-cases

      

    ;;; subfunction

(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)))

                    
;;; mainfunction

(defun rnd-pick* (alist)
  (if (and (listp (first alist)) 
           (floatp (second (first alist))))
    (weighted-random alist)
    (rnd-pick alist)))


;;; examples
                    
;;; without weight
(rnd-pick* '(1 2 3 4 5))
(rnd-pick* '((1 2 3 4) (3 4 5 7 3) (75 392 2)))

;;; with weight
(rnd-pick* '((2 0.2) (3 0.4) (4 0.2)))
(rnd-pick* '(((2 3 4 5) 0.2) ((8 796 5) 0.4)))
(rnd-pick* '(((1 3) 0.2) (3 0.3)))

     

    rnd-symmetrical-position-swap

    in User Extensions Source Code

    Posted · Edited by AM
    edited 

    ;;; SWAPS THE POSITIONS SYMMETRICALLY AND RANDOMIZED 
;;; n => number of generations, output: last gen or all gens...
;;; new-version works also for symmetrical-sequences! (special cas)

(defun rnd-symmetrical-position-swap (n liste &key (out 'all))
  (let ((n1) (n2))
    (progn
      (setf liste (loop repeat n
                    do (setf n1 (random (1- (list-length-divide liste)))
                             n2 (random (1- (list-length-divide liste))))
                    collect (progn 
                              (setf liste (position-swap
                                           (list (list n1 n2) 
                                                 (list 
                                                  (- (1- (length liste)) n1)
                                                  (- (1- (length liste)) n2)))
                                           
                                           liste)))))
      (cond ((equal out 'last)
             (car (last liste)))
            ((equal out 'all)
             (append liste))))))


(rnd-symmetrical-position-swap 2 '(1 2 3 4 3 2 1) :out 'last)
(rnd-symmetrical-position-swap 5 '(1 2 3 4 5 6) :out 'last)
(rnd-symmetrical-position-swap 2 '(a b c d e f g h) :out 'all)

     

    quasi-unsiono(-rnd-walk) by modifying proportions

    in User Extensions Source Code

    Posted 

    ;;; -----------------------------------------------------------------------------------------------
;;; A QUASI-UNISONO by proportional length-differences
;;; SAME PITCHES IN ALL VOICES INCLUDING START/END-PITCH 
;;; -----------------------------------------------------------------------------------------------
;;; a random-pitch-seq (rnd-walk) 
;;;
;;; immediate-pitch-repetitions are building the rhythm
;;;
;;; with MODIFY-PROPORTIONS i'm generating "proportional variants" of this rhythm, in this example
;;; by 16 generations -> then i take the generations 1, 8, and 15 for each voice
;;; 
;;; by "(filter-repeat 1 sequence)" i swallow the immediate-pitch-repetitions for correct
;;; of PITCH- and RHYTHM-phases
;;;
;;; -----------------------------------------------------------------------------------------------

;;; FUNCTION

(defun modify-proportions (n prop-list &key (style 'sharpen))
  (let ((rest-pos (loop for i in prop-list
                    for cnt = 0 then (incf cnt)
                    when (< i 0) collect cnt))
        (prop-list (abs! prop-list))
        (liste))
    (progn 
      (setf liste (append (list prop-list)
                          (loop repeat n
                            when (or (= (length (find-above 1 prop-list)) 1)
                                     (= (length (find-unique prop-list)) 1))
                            collect prop-list
                            else collect (setf prop-list (loop 
                                                           for i in prop-list
                                                           for cnt = 0 then (incf cnt)
                                                           collect (cond ((= cnt (position (find-closest 2 (find-above 1 prop-list)) prop-list))
                                                                          (if (equal style 'sharpen) 
                                                                            (1- i)
                                                                            (1+ i)))
                                                                         ((= cnt (position (find-max prop-list) prop-list))
                                                                          (if (equal style 'sharpen) 
                                                              (1+ i)
                                                                            (1- i)))
                                                           (t i)))))))
      (loop 
        for i in liste
        collect (loop for k in i
                  for cnt = 0 then (incf cnt)
                  when (memberp cnt rest-pos)
                  collect (* -1 k) else collect k)))))


;;; -----------------------------------------------------------------------------------------------

;;; GENERATING SCORE

(setf sequence (gen-walk 100 :step '(0 0 0 0 0 0 0 1 2) :start 'c5))

(setf rhy 1/32)



;;; -----------------------------------------------------------------------------------------------


(def-score quasi-unisono
           (:title "quasi-unisono"
                   :key-signature 'atonal
                   :time-signature '(4 4)
                   :tempo 90)
  
  (instr1    
   :omn (make-omn
         :length (gen-length (nth 1 (modify-proportions 16 (count-repeat sequence) :style 'sharpen)) rhy)
         :pitch (filter-repeat 1 sequence))
   :channel 1
   :port 0
   :sound 'gm)

  (instr2   
   :omn (make-omn
         :length (gen-length (nth 8 (modify-proportions 16 (count-repeat sequence) :style 'sharpen)) rhy)
         :pitch (filter-repeat 1 sequence))
   :channel 2
   :port 0
   :sound 'gm)

  (instr3    
   :omn (make-omn
         :length (gen-length (nth 15 (modify-proportions 16 (count-repeat sequence) :style 'sharpen)) rhy)
         :pitch (filter-repeat 1 sequence))
   :channel 3
   :port 0
   :sound 'gm))

    there is no BUG when i work without "omn-to-time-signature", but is also not necessary!

    snippet problem?

    in Score and Notation

    Posted

    perfect! i thought it was something like that - it seems that it's strange with "every TIE" in such a combination...

     

    also with:

      

    (5q 5q 5h._3q -3q 3q_5h. 5q 5q) 

(t t e._5q -5h. 5q_e. t t)

etc...

    thanks!

    a.

     

    snippet problem?

    in Score and Notation

    Posted

    when i put these lists into MAKE-OMN, i get strange rhy-values, because MAKE-OMN "organizes" the TIED-values different...

    why?

      

    (make-omn :length '(3q 3q 3q_t -e. t_3q 3q 3q)
          :pitch '(a5 f5 b4 ds5 a4 f4))

    have a look how the rhythm-notation changed 

    (3q a5 f5 s_t_3s b4 -e. s_t_3s ds5 3q a4 f4)

     

    thanks

    a.

    modify-proportions

    in User Extensions Source Code

    Posted 

    ;;; ----------------------------------------------------------------
;;; modifying proprtions by add/sub of the smallest/largest values
;;; number of elements is constant / sum of the seq also constant
;;; n => number of generations
;;; prop-list => integers
;;; :style => sharpen or flatten
;;; ----------------------------------------------------------------

(defun modify-proportions (n prop-list &key (style 'sharpen))
  (let ((rest-pos (loop for i in prop-list
                    for cnt = 0 then (incf cnt)
                    when (< i 0) collect cnt))
        (prop-list (abs! prop-list))
        (liste))
    (progn 
      (setf liste (append (list prop-list)
                          (loop repeat n
                            when (or (= (length (find-above 1 prop-list)) 1)
                                     (= (length (find-unique prop-list)) 1))
                            collect prop-list
                            else collect (setf prop-list (loop 
                                                           for i in prop-list
                                                           for cnt = 0 then (incf cnt)
                                                           collect (cond ((= cnt (position (find-closest 2 (find-above 1 prop-list)) prop-list))
                                                                          (if (equal style 'sharpen) 
                                                                            (1- i)
                                                                            (1+ i)))
                                                                         ((= cnt (position (find-max prop-list) prop-list))
                                                                          (if (equal style 'sharpen) 
                                                              (1+ i)
                                                                            (1- i)))
                                                           (t i)))))))
      (loop 
        for i in liste
        collect (loop for k in i
                  for cnt = 0 then (incf cnt)
                  when (memberp cnt rest-pos)
                  collect (* -1 k) else collect k)))))

;;; examples

(modify-proportions 8 '(4 3 -2 7 3 2 7) :style 'sharpen)
(modify-proportions 8 '(4 3 -2 7 3 2 7) :style 'flatten)


(omn-to-time-signature
 (gen-length (modify-proportions 8 '(4 3 2 7) :style 'sharpen) 1/16)
 '(4 4))

(omn-to-time-signature
 (gen-length (modify-proportions 8 '(4 3 2 7) :style 'flatten) 1/16)
 '(4 4))

(list-plot 
 (modify-proportions 10 '(5 3 2 -7 1 8 2))
:point-radius 0 :style :fill)

     

    ...works not in all CASES (when :style 'flatten), but okay...

     

    get-proportions

    in User Extensions Source Code

    Posted 

    ;;; GETTING THE LENGTH-PROPORTIONS AS INTEGERS

(defun get-proportions (omn_seq &key (abs 'nil))
  (let ((denoms))
    (progn 
      (setf denoms (remove-duplicates
                    (loop for i in (omn :length omn_seq)
                      collect (denominator (abs i)))))
      (loop for i in (omn :length omn_seq)
        collect (if (equal abs 't)
                  (* (abs i) (apply 'lcm denoms))
                  (* i (apply 'lcm denoms)))))))

;; examples      
(get-proportions '(-3q 3h_h. d3 mf))
(get-proportions '(5q 5q 5q 5q 5q -e -s t t -q))
(get-proportions '(5q 5q 5q 5q 5q -e -s t t -q) :abs t)
(get-proportions '(-e -t t t t t t t t t -s. -q))


;;; HOW TO USE

(setf rhy '(-3h 3q_5h. 5q 5q c4))
(setf props (get-proportions rhy :abs nil))


;;; you can use that for GEN-LENGTH-CONSTANT

;; ordinary
(gen-length-constant props 'w.)
;; a bit advanced
(gen-length-constant props 'h.)
;; crazy 
(gen-length-constant props 'h._e)

     

    pattern-match with overwrite

    in User Extensions Source Code

    Posted

    i see 4 possibilities...

    1) you could work in generations => only 1 match per gen => but it could end in a stack overflow (when it's recursiv, when match is also inside the insert)

    2) could overwrite in generations from last to first match -> means right to left in the list (but not with matches inside the insert) => so when it's more then one match it will be overlapping

    3) could generate overlaying voices by few matches

    4) you could limited it by &key :nooverlapping 't

    added 4 minutes later

    if it will work, i wll code a nice example for OM to present it :smile:

    pattern-match with overwrite

    in User Extensions Source Code

    Posted

    sorry but with this code - evaluating all i have...

    only for THIS input-seq ... you input-seq seems different

      

    
(setf seq '(e c4 -e -q q d4 -q s c4 -e. -h. q))

(setf insert '(3q c4 d4 e4 c4 d4 e4 c4 d4 -3q))
(setf insert-span (loop for i in (omn :length insert)
                    sum (abs i)))

(progn
  (setf new-list
        (loop for i in (single-events seq)
          with match = 0
          when (pattern-matchp i '(q d4 ?)) do (setf match 1)
          when (= match 1)
          collect (abs (car (omn :length i))) into bag 
          when (and (= match 1) (<= (sum bag) insert-span)) collect (* -1 (abs (car (omn :length i))))
          else collect i
          
          ))

  (flatten (loop for x in new-list
             with match = 0
             when (and (atom x) (= match 0)) collect insert and do (setf match 1)
             when (listp x) collect x)))
                                       
                                       
 => (e c4 mf -e -q 3q c4 d4 e4 c4 d4 e4 c4 d4 -3q -h. q c4 mf)

     

    pattern-match with overwrite

    in User Extensions Source Code

    Posted

    sorry, but this would be easy (for beginners :smile:)

    ...but that's not correct because it is INSERTRED and not OVERWRITED... 

     

    there is NO function in OM that's doing this. 

    greetings from "helmut" :bigsmile: ...because if you want work with "strukturnetze" you have to keep the NET correct and not to shift the time values (how it is with pattern-map)... so you have to overwrite

    pattern-match with overwrite

    in User Extensions Source Code

    Posted

    dear all

    i'll try to code a function that overwrites the SEQ with an insert after a pattern-match... not so simple, because to calculate all the length-values in the SEQ so that there ist no "shifting" ist very....

     

    here an easy sketch... but with a simple, so that i haven't got to calculate (beacuse all is mapped on quaternotes)...

    i hope anyone could CODE that... would be an interesting FUNCTION!!! using things as a NET!!

     

    compare -> seq with the function output... the you see the idea

     

      

    (setf seq '(e c4 -e -q q d4 -q s c4 -e. -h. q))

(setf insert '(3q c4 d4 e4 c4 d4 e4 c4 d4 -3q))
(setf insert-span (loop for i in (omn :length insert)
                    sum (abs i)))

(progn
  (setf new-list
        (loop for i in (single-events seq)
          with match = 0
          when (pattern-matchp i '(q d4 ?)) do (setf match 1)
          when (= match 1)
          collect (abs (car (omn :length i))) into bag
          
          when (and (= match 1) (<= (sum bag) insert-span)) collect (* -1 (abs (car (omn :length i))))
          else collect i
          
          ))

  (flatten (loop for x in new-list
             with match = 0
             when (and (atom x) (= match 0)) collect insert and do (setf match 1)
             when (listp x) collect x)))

     

    pattern-map/match overwriting

    in OMN Lingo

    Posted

    a question:

     

    in a pattern match i would like to overwrite the existing OMN sequence. that means that for the duration of the insert the original OMN-sequence is not pushed backwards. As I see it now, the OMN-values are only inserted and do not overwrite the sequence, (and not rhythmically "compensating") ... ?

     

    would be very nice! ...or i have to code it for myself :sad:

     

    an example: 

    ;; basic omn-seq
'(e c4 -e -q q c4 -q s c4 -e. q)

;; insert
'(3q c4 d4 e4 c4 d4 e4 c4 d4)

;; pattern-match on (q c4)

;; result should be
'(e c4 -e -q 3q c4 d4 e4 c4 d4 e4 c4 d4 -3q q c4)

     

×
×
  • Create New...

Important Information

Terms of Use Privacy Policy

  I accept