Author: ksprotte Date: Thu Aug 9 05:53:10 2007 New Revision: 28
Modified: trunk/morphologie.asd trunk/src/missing-om-functions.txt trunk/src/morphologie.lisp trunk/src/utils.lisp Log: release 3.0.3
Modified: trunk/morphologie.asd ============================================================================== --- trunk/morphologie.asd (original) +++ trunk/morphologie.asd Thu Aug 9 05:53:10 2007 @@ -4,7 +4,7 @@ #+sbcl (setq sb-impl::*default-external-format* :latin-1)
(defsystem :morphologie - :version "3.0.1" + :version "3.0.3" :components ((:static-file "morphologie.asd") (:static-file "load.lisp") @@ -14,4 +14,4 @@ ((:file "package") (:file "utils") (:file "morphologie")))) - :depends-on (:ompw)) + :depends-on (:ompw :ompw-utils))
Modified: trunk/src/missing-om-functions.txt ============================================================================== --- trunk/src/missing-om-functions.txt (original) +++ trunk/src/missing-om-functions.txt Thu Aug 9 05:53:10 2007 @@ -1,18 +1 @@ -om::dx->x -om::arithm-ser -om::x-append -om::create-list -om::om-round -om::g-scaling/sum -om::sort-list -om::om/ -om::posn-match -om::om- -om::nth-random -om::permut-random -om::list-explode -om::om-abs -om::om// -om::flat -om::x->dx -om::om+ +;; there are no more missing functions :) \ No newline at end of file
Modified: trunk/src/morphologie.lisp ============================================================================== --- trunk/src/morphologie.lisp (original) +++ trunk/src/morphologie.lisp Thu Aug 9 05:53:10 2007 @@ -12,13 +12,73 @@ ;;;
;;; the encoding of this file is latin-1 -;;; that's the best common demoninator +;;; that's the best common denominator
(in-package :morph)
-;;; watch out for functions like OM::.... -;;; still in this file +(define-menu morphologie) +(in-menu morphologie)
+(define-menu analysis :in morphologie) +(in-menu analysis) +(menu-add-symbol ptrn-find) +(menu-add-symbol ptrn-reson) +(menu-add-symbol ptrn-smooth) +(menu-add-symbol ins-ptrn) +(menu-add-symbol min-flex-max) +(menu-add-symbol direct-analysis) +(menu-add-symbol find-permut) +(menu-add-symbol contrasts-lev.1) +(menu-add-symbol contrasts-all-lev) +(menu-add-symbol new-old-analysis) +(menu-add-symbol energy-prof-morph-analysis) + +(define-menu structure :in morphologie) +(in-menu structure) +(menu-add-symbol structure-1) +(menu-add-symbol structure-2) + +(define-menu reconstitute :in morphologie) +(in-menu reconstitute) +(menu-add-symbol 1-0-1-reconst) +(menu-add-symbol reconstitute) +(menu-add-symbol struct2-to-seq) + +(define-menu distance :in morphologie) +(in-menu distance) +(menu-add-symbol euclidian-d) +(menu-add-symbol distance) +(menu-add-symbol ldl-distance) +(menu-add-symbol multi-distance) +(menu-add-symbol resemblance) +(menu-add-symbol prim-tree) +(menu-add-symbol tree-path) +(menu-add-symbol draw-tree) + +(define-menu classification :in morphologie) +(in-menu classification) +(menu-add-symbol s-class) +(menu-add-symbol class-1) +(menu-add-symbol meta-class1) +(menu-add-symbol quantize-1) +(menu-add-symbol entropy) +(menu-add-symbol e-test) + +(define-menu utilities :in morphologie) +(in-menu utilities) +(menu-add-symbol delta) +(menu-add-symbol smooth) +(menu-add-symbol midiseq->alpha) +(menu-add-symbol rep-by-flag) +(menu-add-symbol mc->alpha) +(menu-add-symbol str->symb) +(menu-add-symbol concatstrings) +(menu-add-symbol l-matrix) + +;;; internal-boxes will in fact contain all boxes that follow +(menu-separator) +(define-menu internal-boxes :in morphologie :print-name "Internal-Boxes") +(in-menu internal-boxes)
;; I tried to get this version of LIST-MODULO to run - but there is a problem ;; with this code. @@ -37,14 +97,6 @@ ;; :do (push (remove nil (nreverse (svref vector i))) res)) ;; (nreverse res)))
-(define-menu morphologie) -(in-menu morphologie) - -;;; until all OM symbols are out -(eval-when (:compile-toplevel :load-toplevel :execute) - (unless (find-package :om) - (defpackage :om (:use :cl)))) - (define-box list-modulo (list &optional ncol) "partitions LIST in NCOL lists containing the elements modulo NCOL" :non-generic t @@ -244,7 +296,7 @@ (remove-if #'(lambda (x) (< (cadr x) max)) list)))
(define-box ptrn-reson ((list (a b c a b c b b b b a a)) (windw 5) &optional - (step nil) (set nil)) + (step nil) (set nil)) "Avance dans la sequence LIST avec avec une taille de fenetre WINDW et un pas d'avancement (optionnel) STEP . Renvoie pour chaque fen�tre le nombre d'occurrences d'un �l�ment. @@ -345,7 +397,7 @@ (push (list seqa i) r))))))))
(define-box find-permut ((seq nil) (output :permut) &optional (length nil) - (ptrn nil)) + (ptrn nil)) "Renvoie les permutations de deux elements de la sequence SEQ> deux modes : PERMUTATION renvoie les segments d'elements permutes, POSITION renvoie les segments d'elements et leurs positions dans la sequence. @@ -373,11 +425,9 @@ (mapcar #'car r) (mapcar #'(lambda (x) (mapcar #'car x)) r)))))))
-(menu-separator) - (define-box ldl-distance ((l-seq ((a b c) (a b b) (a b c))) (change 1.0) - (ins/sup 1.0) (inex 0.0) (scale :abs) - (result :short)) + (ins/sup 1.0) (inex 0.0) (scale :abs) + (result :short)) "Estimates the distances between lists of symbols. INPUT l-seq : list of lists of symbols; @@ -738,7 +788,7 @@ (format stream "~%~%"))))
(define-box structure-1 ((seq (a b c a b c d a c c d a a b c a)) &optional (alpha? :alpha) (smooth? :yes) - (result :extend) (levels 1) (smth2? :no)) + (result :extend) (levels 1) (smth2? :no)) "Donne toutes les structures possibles d'une s�quence de nombres ou de symboles selon une segmentation contrastive, et ce de mani�re r�cursive.
@@ -1112,7 +1162,7 @@ lisse2))))))
(define-box rma-1 ((seq nil) (smoo1 1) (levels 1) &optional (smoo2 0) - (alpha? 1) (result 0)) + (alpha? 1) (result 0)) " m�me fonction que structure-1, mais r�cursive : s'applique aussi aux structures trouv�es, avec LEVELS @@ -1451,7 +1501,7 @@ (position-if #'match list-dom)))
(define-box ins-ptrn ((seq (1 2 3 4 1 2 5 3 4)) (ptrn ((1 2 3 4) (1 2))) - &optional (prof 1) (set nil) (marg 3)) + &optional (prof 1) (set nil) (marg 3)) "Finds the pattern(s) PTRN in list seq with or without up to a number prof inserted items; Return each pattern and its start positions. @@ -1541,7 +1591,7 @@
(define-box structure-2 ((seq nil) (n-max 10) (alpha? 1) (result 0) &optional - (length nil) (seuil 10)) + (length nil) (seuil 10)) "INPUT seq = sequence of nums or symbols; n-max = maximum number of patterns accepted in structure of seq; @@ -1667,7 +1717,7 @@ (calcoletto (mapcar #'(lambda (x) (first x)) compl)) (calcolaccio (dolist (k calcoletto (nreverse ros)) - (push (OM::posn-match list-of-pat k) ros)))) + (push (ompw-utils:posn-match list-of-pat k) ros)))) (mat-trans (list calcolo calcolaccio))))
(define-box forma ((analys nil) (seq nil) (seuil 1)) @@ -1784,7 +1834,7 @@
(define-box class-1 ((matrix nil) (n 2) &optional (alpha? 0) (centers nil) - (verbose :no)) + (verbose :no)) "Clustering 'mouving-clouds' algorithm. Classify elements in matrix of d-dimensions into n classes. The nth element in result-list corresponds to the nth element (line) of matrix. @@ -2452,9 +2502,9 @@ (reverse (remove-duplicates r :key #'cadr))))
(define-box min-flex-max ((seq - (6000 4000 5600 4700 4100 5900 6400 7800 7400 6300 - 6800 8300 5900)) - (result 1) &optional (d-cte nil)) + (6000 4000 5600 4700 4100 5900 6400 7800 7400 6300 + 6800 8300 5900)) + (result 1) &optional (d-cte nil)) "analyse une sequence en detectant trois formes primitives: minima: element pr�c�d� et suivi par un �l�ment de valeur plus grande. @@ -2500,7 +2550,7 @@ renvoie une liste de points depuis une liste d'intervalles . commence � zero" :non-generic t - (OM::dx->x 0 list)) + (ompw-utils:dx->x 0 list))
(define-box reconst-prim (list start) @@ -2565,32 +2615,32 @@ :non-generic t (let ((ris nil) (start 0)) (dolist (y list - (OM::flat + (ompw-utils:flat (if (equalp "flex" (first (first list))) (nreverse ris) (cons start (nreverse ris))))) (push (cond ((equalp (first y) "min") - (rest (OM::x-append - (OM::arithm-ser start (* -1 (second y)) -1) - (rest (OM::arithm-ser (* -1 (second y)) start - 1))))) + (rest (ompw-utils:x-append + (ompw-utils:arithm-ser start (* -1 (second y)) -1) + (rest (ompw-utils:arithm-ser (* -1 (second y)) start + 1))))) ((equalp (first y) "max") - (rest (OM::x-append - (OM::arithm-ser start (second y) 1) - (rest (OM::arithm-ser (second y) start -1))))) + (rest (ompw-utils:x-append + (ompw-utils:arithm-ser start (second y) 1) + (rest (ompw-utils:arithm-ser (second y) start -1))))) ((equalp (first y) "flex") - (OM::create-list (second y) start))) + (make-list (second y) :initial-element start))) ris))))
(defun rec-st-2 (struct |N�| &optional seq) (let* ((rs (nth |N�| struct)) (risultato - (mapcar #'(lambda (x) (OM::flat (nth x (cadr rs)))) + (mapcar #'(lambda (x) (ompw-utils:flat (nth x (cadr rs)))) (mapcar #'1- (cadar rs))))) (if seq - (mapcar #'(lambda (x) (nth x seq)) (OM::flat risultato)) - (OM::flat risultato)))) + (mapcar #'(lambda (x) (nth x seq)) (ompw-utils:flat risultato)) + (ompw-utils:flat risultato))))
(define-box struct2-to-seq ((struct nil) (n nil) &optional ptrns) "Reconstruit une s�quence correspondant � la structure donn�e en struct. @@ -2616,9 +2666,9 @@ pi� eventualmente l'indice di profondit�" :non-generic t (let ((ris nil)) - (dotimes (x (length list) (OM::flat (nreverse ris))) + (dotimes (x (length list) (ompw-utils:flat (nreverse ris))) (push (cond ((equalp (first (nth x list)) "max") - (OM::x-append + (ompw-utils:x-append (arithm-ser2 start (* -1 (/ (- start (second (nth x list))) (third (nth x list)))) @@ -2627,7 +2677,7 @@ (/ (- start (second (nth x list))) (third (nth x list))) (third (nth x list))))) ((equalp (first (nth x list)) "min") - (OM::x-append + (ompw-utils:x-append (arithm-ser2 start (* -1 (/ (- start (second (nth x list))) (third (nth x list)))) @@ -2636,8 +2686,8 @@ (/ (- start (second (nth x list))) (third (nth x list))) (third (nth x list))))) ((equalp (first (nth x list)) "flex") - (OM::create-list (third (nth x list)) - (second (nth x list))))) + (make-list (third (nth x list)) + :initial-element (second (nth x list))))) ris))))
@@ -2647,7 +2697,7 @@ :non-generic t (let ((ris nil) (valore nil)) (dotimes (x (length list) - (OM::flat (OM::x-append (nreverse ris) start))) + (ompw-utils:flat (ompw-utils:x-append (nreverse ris) start))) (cond ((and (and (equalp (second (nth x list)) "min") (= x 0)) (< start (third (nth x list)))) (format t @@ -2660,10 +2710,10 @@ (abort)) ((and (equalp (second (nth x list)) "min") (= x 0)) (setf valore - (OM::x-append + (ompw-utils:x-append (arithm-ser2 start (* -1.0 - (abs (OM::om-round + (abs (ompw-utils:m-round (/ (- (third (nth 0 list)) start) (fourth (nth 0 list)))))) (fourth (nth 0 list))) @@ -2671,10 +2721,10 @@ (push valore ris)) ((and (equalp (second (nth x list)) "max") (= x 0)) (setf valore - (OM::x-append + (ompw-utils:x-append (arithm-ser2 start (* 1.0 - (abs (OM::om-round + (abs (ompw-utils:m-round (/ (- (third (nth 0 list)) start) (fourth (nth 0 list)))))) (fourth (nth 0 list))) @@ -2682,10 +2732,10 @@ (push valore ris)) ((equalp (second (nth x list)) "min") (setf valore - (OM::x-append + (ompw-utils:x-append (rest (arithm-ser2 (first (last valore)) (* -1.0 - (abs (OM::om-round + (abs (ompw-utils:m-round (/ (- (third (nth x list)) (third (nth (- x 1) list))) (- (first (nth x list)) @@ -2700,10 +2750,10 @@ (push valore ris)) ((equalp (second (nth x list)) "max") (setf valore - (OM::x-append + (ompw-utils:x-append (rest (arithm-ser2 (first (last valore)) (* 1.0 - (abs (OM::om-round + (abs (ompw-utils:m-round (/ (- (third (nth x list)) (third (nth (- x 1) list))) (- (first (nth x list)) @@ -2718,8 +2768,8 @@ (push valore ris)) ((equalp (second (nth x list)) "flex") (setf valore - (OM::create-list (fourth (nth x list)) - (third (nth x list)))) + (make-list (fourth (nth x list)) + :initial-element (third (nth x list)))) (push valore ris))))))
@@ -2729,8 +2779,8 @@ :non-generic t (let* ((ris nil) (ros nil) - (ottave1 (OM::om// (OM::om// list1 1200) modul)) - (ottave2 (OM::om// (OM::om// list2 1200) modul)) + (ottave1 (ompw-utils:m-floor (ompw-utils:m-floor list1 1200) modul)) + (ottave2 (ompw-utils:m-floor (ompw-utils:m-floor list2 1200) modul)) (studio (dotimes (x (length ottave1) (nreverse ris)) (push (- (nth x ottave1) (nth x ottave2)) ris)))) @@ -2755,8 +2805,8 @@ "Studia gli intervalli di due liste e ne fa una analisi" :non-generic t (let ((ris nil) - (intervalli1 (OM::x->dx list1)) - (intervalli2 (OM::x->dx list2))) + (intervalli1 (ompw-utils:x->dx list1)) + (intervalli2 (ompw-utils:x->dx list2))) (dotimes (x (length intervalli1) (apply '+ (nreverse ris))) (when (not (equalp (nth x intervalli1) (nth x intervalli2))) (push 1 ris))))) @@ -2770,12 +2820,12 @@ (ros nil) (rapporto1 (dotimes (x (- (length list1) 1) (nreverse ris)) - (push (OM::om-round + (push (ompw-utils:m-round (/ (abs (nth (+ 1 x) list1)) (abs (nth x list1))) 2) ris))) (rapporto2 (dotimes (k (- (length list2) 1) (nreverse ros)) - (push (OM::om-round + (push (ompw-utils:m-round (/ (abs (nth (+ 1 k) list2)) (abs (nth k list2))) 2) ros)))) (if (equalp rapporto1 rapporto2) 'ok 'no))) @@ -2801,12 +2851,12 @@ (rus nil) (rapporto1 (dotimes (x (- (length list1) 1) (nreverse ris)) - (push (OM::om-round + (push (ompw-utils:m-round (/ (abs (nth (+ 1 x) list1)) (abs (nth x list1))) 2) ris))) (rapporto2 (dotimes (k (- (length list2) 1) (nreverse ros)) - (push (OM::om-round + (push (ompw-utils:m-round (/ (abs (nth (+ 1 k) list2)) (abs (nth k list2))) 2) ros)))) (if (equalp rapporto1 rapporto2) (push 1 rus)))) @@ -2815,7 +2865,7 @@ (defun mini (l) "Returns the minimum value of a list" (car (sort l '<)))
(define-box dist-1-ldl ((seq1 nil) (seq2 nil) (change 1) (ins/sup 1) - (wgth (1 1 1 1))) + (wgth (1 1 1 1))) "" :non-generic t (cond ((not (equalp (length (car seq1)) (length (car seq2)))) @@ -2831,7 +2881,7 @@ "~%WARNING : bad definition of wgth; setting all weigths to the first of wgth list...~%Look at the documentation.") (make-list (length (car seq1)) :initial-element (car wgth))) (t wgth)))) - (setf wgth (OM::g-scaling/sum wgth 1.0)) + (setf wgth (ompw-utils:m-scaling/sum wgth 1.0)) (dotimes (x (length matrix1) (sqrt ris)) (setf ris (+ ris @@ -2841,7 +2891,7 @@
(define-box dist-2-ldl ((seq1 nil) (seq2 nil) (change 1) (ins/sup 1) (inex 0) - (wgth (1 1 1 1))) + (wgth (1 1 1 1))) "" :non-generic t (cond ((not (equalp (length (car seq1)) (length (car seq2)))) @@ -2857,7 +2907,7 @@ "~%WARNING : bad definition of wgth; setting all weigths to the first of wgth list...~%Look at the documentation.") (make-list (length (car seq1)) :initial-element (car wgth))) (t wgth)))) - (setf wgth (OM::g-scaling/sum wgth 1.0)) + (setf wgth (ompw-utils:m-scaling/sum wgth 1.0)) (dotimes (x (length matrix1) (sqrt ris)) (setf ris (+ ris @@ -2911,7 +2961,7 @@
(define-box dist-2 ((seq1 nil) (seq2 nil) (change 1) (ins/sup 1) (inex 0) - (scale 1)) + (scale 1)) "Returns the smallest distance between two lists of symbols seq1 and seq2 Args : change = cost when changing a symbol in a list without deletion or insertion @@ -2978,7 +3028,7 @@
(define-box distance ((seq1 (a b c d e)) (seq2 (a b c d e)) (change 1) - (ins/sup 1) (scale 1) &optional (inex nil)) + (ins/sup 1) (scale 1) &optional (inex nil)) "Returns the smallest distance between two lists of symbols seq1 and seq2 Args : change = cost when changing a symbol in a list without deletion or insertion @@ -2995,7 +3045,7 @@
(define-box multi-distance ((seq1 nil) (seq2 nil) (change 1) (ins/sup 1) - (wgth (1 1 1 1)) &optional (inex nil)) + (wgth (1 1 1 1)) &optional (inex nil)) "Applique la distance d'�dition � une liste de s�quences avec une pond�ration (entre 0 et 1) pour chaque �l�ment (ou position) des listes." @@ -3026,7 +3076,7 @@ (mapcar #'(lambda (e) (position e list :test #'equalp)) list))
(define-box resemblance ((a nil) (b nil) (wocc 1.0) (wref 1.0) &optional - (diff :res)) + (diff :res)) "Calcule une valeur de ressemblance entre 0 et 100 entre deux s�quences de symboles selon le crit�re de leur structure interne. Wocc : poids de la structure d'occurence; @@ -3079,13 +3129,13 @@ (dotimes (x (- (length lista) 1) (nreverse ris)) (push (/ (+ (nth x lista) (nth (1+ x) lista)) 2) ris))))
-(define-box mean-derivation ((list nil) (GR\� 0) &optional (note? nil)) +(define-box mean-derivation ((list nil) (GR 0) &optional (note? nil)) "" :non-generic t (let* ((calcolo - (if (= 1 GR\�) + (if (= 1 GR) (med-fix list) - (mean-derivation (med-fix list) (- GR\� 1) note?))) + (mean-derivation (med-fix list) (- GR 1) note?))) (con-note (when note? (notes-change calcolo note? 48)))) (if note? con-note calcolo)))
@@ -3106,13 +3156,13 @@ (push (/ (apply '+ (nth x calcolo)) (length (nth x calcolo))) ris))))
-(define-box variable-derivation ((lista nil) (windw 2) (GR\� 1)) +(define-box variable-derivation ((lista nil) (windw 2) (GR 1)) "Restituisce le dirivate variabili successive secondo il valore scelto in GRADO. N rappresenta il valore con cui effettuare la media." :non-generic t - (if (= 1 GR\�) + (if (= 1 GR) (med-var lista windw) - (variable-derivation (med-var lista windw) (- GR\� 1) windw))) + (variable-derivation (med-var lista windw) (- GR 1) windw)))
(define-box notes-change ((pits 6000) (scale 6000) &optional (mod 12)) @@ -3121,24 +3171,24 @@ (let* ((pits (list! pits)) (scale (list! scale)) (modsca - (OM::om// - (OM::sort-list + (ompw-utils:m-floor + (sort-list (remove-duplicates - (OM::om// (OM::om/ scale (/ 100 (/ mod 12))) - mod))))) + (ompw-utils:m-floor (ompw-utils:m/ scale (/ 100 (/ mod 12))) + mod))))) (pitmods - (OM::om// (OM::om/ pits (/ 100 (/ mod 12))) mod)) + (ompw-utils:m-floor (ompw-utils:m/ pits (/ 100 (/ mod 12))) mod)) (octa (octave pits)) (posdifs (mapcar #'(lambda (p) (position (g-min - (OM::om-abs - (OM::om- modsca p))) - (OM::om-abs - (OM::om- modsca p)))) + (ompw-utils:m-abs + (ompw-utils:m- modsca p))) + (ompw-utils:m-abs + (ompw-utils:m- modsca p)))) pitmods))) (mapcar #'(lambda (index octave) (makenote index octave mod)) - (OM::posn-match modsca posdifs) + (ompw-utils:posn-match modsca posdifs) octa)))
@@ -3146,7 +3196,7 @@ "retourne l'octave � partir de c3=octave 3" :non-generic t (let ((midic (list! midic))) - (mapcar #'(lambda (x) (OM::om- (OM::om// x 1200) 2)) + (mapcar #'(lambda (x) (ompw-utils:m- (ompw-utils:m-floor x 1200) 2)) midic)))
@@ -3172,7 +3222,7 @@ "Prepara interlock : non mi ricordo cosa fa esattamente." :non-generic t (let ((ris nil) (y (lettura-modulare list1 list2))) - (OM::flat + (ompw-utils:flat (append (dotimes (x (1- (length list1)) (nreverse ris)) (push (mat-trans (list (list (nth x list1)) @@ -3201,27 +3251,27 @@ (otherwise (error "Got ~s, was expecting one of 1, 2." total))))
-(define-box interlock ((list1 nil) (list2 nil) (GR\� 1)) +(define-box interlock ((list1 nil) (list2 nil) (GR 1)) "Interpone una lista2 alla lista1 e prende aleatoriamente le note della lista2" :non-generic t - (if (= GR\� 1) - (inter-profile list1 (OM::permut-random list2)) - (interlock (inter-profile list1 (OM::permut-random list2)) - (permut-circ list2 (1- (length list1))) (- GR\� 1)))) + (if (= GR 1) + (inter-profile list1 (ompw-utils:permute-random list2)) + (interlock (inter-profile list1 (ompw-utils:permute-random list2)) + (permut-circ list2 (1- (length list1))) (- GR 1))))
(define-box new-inter-profile ((list1 nil) (list2 nil)) "Prepara interlock : non mi ricordo cosa fa esattamente." :non-generic t (let ((ris nil) (y (lettura-modulare list1 list2))) - (OM::flat + (ompw-utils:flat (append (dotimes (x (1- (length list1)) (nreverse ris)) (push (mat-trans (list (list (nth x list1)) (list - (OM::om+ - (OM::nth-random + (ompw-utils:m+ + (ompw-utils:nth-random (list 1200 0 -1200)) (trans-approx (list (nth x y)) @@ -3232,33 +3282,33 @@ (last list1)))))
-(define-box new-interlock ((list1 nil) (list2 nil) (GR\� 1)) +(define-box new-interlock ((list1 nil) (list2 nil) (GR 1)) "Interpone una lista2 alla lista1 e prende aleatoriamente le note della lista2" :non-generic t - (if (= GR\� 1) - (new-inter-profile list1 (OM::permut-random list2)) - (new-interlock (new-inter-profile list1 (OM::permut-random list2)) - (permut-circ list2 (1- (length list1))) (- GR\� 1)))) + (if (= GR 1) + (new-inter-profile list1 (ompw-utils:permute-random list2)) + (new-interlock (new-inter-profile list1 (ompw-utils:permute-random list2)) + (permut-circ list2 (1- (length list1))) (- GR 1))))
(defun int-com-ottava (lista) "Restituisce l'intervallo complementare ad ull'intervallo in 'lista' ma all'interno di un'ottava." (let ((ris nil)) - (OM::flat + (ompw-utils:flat (dotimes (x (- (length lista) 1) (nreverse ris)) - (push (OM::x->dx + (push (ompw-utils:x->dx (append (list (nth x lista)) (list (- (nth x lista) (* (- 12 (mod (/ (- - (first (OM::x->dx lista)) + (first (ompw-utils:x->dx lista)) (* (first - (OM::om// - (OM::x->dx lista) + (ompw-utils:m-floor + (ompw-utils:x->dx lista) 1200)) 1200)) 100) @@ -3322,10 +3372,10 @@ des valeurs donn�es en entr�e." :non-generic t (let ((ris nil)) - (dotimes (x (length (OM::x->dx list)) (nreverse ris)) - (cond ((> (nth x (OM::x->dx list)) 0) (push '1 ris)) - ((< (nth x (OM::x->dx list)) 0) (push '-1 ris)) - ((= (nth x (OM::x->dx list)) 0) (push '0 ris)))))) + (dotimes (x (length (ompw-utils:x->dx list)) (nreverse ris)) + (cond ((> (nth x (ompw-utils:x->dx list)) 0) (push '1 ris)) + ((< (nth x (ompw-utils:x->dx list)) 0) (push '-1 ris)) + ((= (nth x (ompw-utils:x->dx list)) 0) (push '0 ris))))))
(defun int-com (lista) @@ -3333,27 +3383,27 @@ prima nota dell'intervallo stesso. Questo significa che se ho SOL3 DO4, la funzione restituisce do4 sol4." (let ((ris nil)) - (OM::flat + (ompw-utils:flat (dotimes (x (- (length lista) 1) (nreverse ris)) - (push (OM::x->dx + (push (ompw-utils:x->dx (append (list (nth x lista)) (list (- (- (nth x lista) (* (- 12 (mod (/ (- - (first (OM::x->dx lista)) + (first (ompw-utils:x->dx lista)) (* (first - (OM::om// - (OM::x->dx lista) + (ompw-utils:m-floor + (ompw-utils:x->dx lista) 1200)) 1200)) 100) 12)) 100)) - (* (first (OM::om// - (OM::x->dx lista) + (* (first (ompw-utils:m-floor + (ompw-utils:x->dx lista) 1200)) 1200))))) ris))))) @@ -3468,7 +3518,7 @@ i limiti di esistenza." :non-generic t (let ((risultato (doppio-reflex-int list value)) (ris nil)) - (dolist (y risultato (OM::flat (nreverse ris))) + (dolist (y risultato (ompw-utils:flat (nreverse ris))) (push (if (int y value) y (correttore-doppio-reflex-int (list! (1+ y)) value)) @@ -3540,7 +3590,7 @@ li raggruppa in sotto-liste." :non-generic t (let ((ris nil)) - (dolist (y list (OM::list-explode (nreverse ris) (length list))) + (dolist (y list (ompw-utils:list-explode (nreverse ris) (length list))) (dolist (x modulo) (push (mod y x) ris)))))
@@ -3548,7 +3598,7 @@ "Restituisce i valori che sono tutti multupli dei moduli messi in Moduli." :non-generic t - (let ((ris nil) (calcolo (distanza-modulo list (OM::om-abs moduli)))) + (let ((ris nil) (calcolo (distanza-modulo list (ompw-utils:m-abs moduli)))) (dotimes (x (length list) (nreverse ris)) (if (subsetp (list 0) (list! (nth x calcolo)) :test #'equal) (push (nth x list) ris) @@ -3562,19 +3612,19 @@ :non-generic t (let ((ris nil)) (dolist (y rht (nreverse ris)) - (if (= (OM::om// y val) 0) + (if (= (ompw-utils:m-floor y val) 0) (push y ris) - (push (- y (OM::om// y val)) ris))))) + (push (- y (ompw-utils:m-floor y val)) ris)))))
(define-box tutti-int ((list nil) (ref 1)) "Calcola gli intervalli che ci sono fra una lista di note ed un'unica nota di riferimento." :non-generic t - (OM::flat + (ompw-utils:flat (let ((ris nil)) (dolist (y list (nreverse ris)) - (push (OM::x->dx (list ref y)) ris))))) + (push (ompw-utils:x->dx (list ref y)) ris)))))
(define-box segno+picc ((list nil)) @@ -3596,7 +3646,7 @@ (define-box tieni-nota ((list nil) (ref 1)) "tiene la nota pi� vicina." :non-generic t - (OM::om+ ref (nota-vicina list ref))) + (ompw-utils:m+ ref (nota-vicina list ref)))
(define-box vicini-valori ((list1 nil) (refs nil)) @@ -3923,7 +3973,7 @@ remarkable-nodes)))
(define-box draw-tree ((tree nil) &optional (nodes nil) (name nil) - (fontname "times") (fontsize 12) (fontstyle :normal)) + (fontname "times") (fontsize 12) (fontstyle :normal)) "Draw in a new window a graphic representation of the Prim tree. TREE : a tree list from Prim-tree. Optional arguments : @@ -4501,9 +4551,130 @@ "" (add-to-datase name))
-;;; just a test - I will remove it -(menu-separator) -(menu-add-symbol +) + +;;; Paolo Aralla code + +(define-box contrasts-lev.1 (sequence) + :non-generic t + "The Analysis of the Contrasts, formulated by Herv� Rivi�re and Frederic Voisin, and implemented in the OpenMusic Morphologie Library, is a model able to describe the becoming of the form in the time. +It points out the hierarchic relation created by the temporal sequence of the events: in fact, for the mnemonic activity, each event is datum point for every following event and datum point for the previous ones. +The numerical transcription carried out through the Analysis of Contrasts describes the entry order of the events in the time. +We could define the numerical transcription created using the analysis of contrasts as morphological structure of the entry order of the events. +From this starting point it is possible to identify the presence of internal patterns and analyse their potential capacity to describe and re-establish the form in its original status. + +exemple: Contrasts-lev.1 (a d f g f) ------> (1 2 3 4 3) +" + :icon + 128 + (let* ((elements (reverse (remove-duplicates (reverse sequence)))) ; TODO use from-end t + (order (ompw-utils:arithm-ser 1 (length elements) 1)) + (analisis-contrasts-level.1 + (mapcar #'(lambda (x y) + (mapcar #'(lambda (z) (if (equalp x z) y 'nil)) sequence)) + elements + order))) + (ompw-utils:flat (ompw-utils:mat-trans (mapcar #'(lambda (list) (remove nil list)) analisis-contrasts-level.1))))) + + +(define-box contrasts-all-lev (sequence) + :non-generic t + "The Analysis of the Contrasts, formulated by Herv� Rivi�re and Frederic Voisin, and implemented in the OpenMusic Morphologie Library, is a model able to describe the becoming of the form in the time. +It points out the hierarchic relation created by the temporal sequence of the events: in fact, for the mnemonic activity, each event is datum point for every following event and datum point for the previous ones. +The numerical transcription carried out through the Analysis of Contrasts describes the entry order of the events in the time. +We could define the numerical transcription created using the analysis of contrasts as morphological structure of the entry order of the events. +From this starting point it is possible to identify the presence of internal patterns and analyse their potential capacity to describe and re-establish the form in its original status. + +exemple: Contrasts-all-lev (a d f g f) ------> ((1 2 3 4 3) (1 2 3 2) (1 2 1) (1 2))" + :icon + 128 + (let* ((counter-sequence (ompw-utils:arithm-ser (length sequence) 1 -1)) + (contrasts-lev.1-for-all-level + (mapcar #'(lambda (x) + (contrasts-lev.1 (last sequence x))) + counter-sequence))) + (butlast contrasts-lev.1-for-all-level))) + + +(define-box new-old-analysis ((sequence (a b c d e f g a b c h u i o p))) + "The analysis of contrasts, which is the function at heart of the Morphologie Library developed by Jacopo Baboni Schilingi and Frederic Voisin, identifies the occurrences within any sequence of events. +Such analysis is of quantitative type, and has considerable development potentialities towards a qualitative description of the processes that put in relation morphologic structure of the message, mnemonic�perceptive activity and psychic response. +The hierarchies that the analysis of contrasts describes become qualitatively pertinent to the mnemonic activity. +We have called New/Old Analysis the function that describes the newness level of an event in relation to the context in which it appears. +The importance of such a function is crucial, because it describes from the point of view of the psychic response the different newness level of the single event in the time. +The steps to define New/Old Analysis are three: + +1. Measurement of the distances: +it allows to quantify the local distance between the different events in relation to their first appearance in the time. + +(defun distances (sequence) + (mapcar #' (lambda (x) (x->dx x)) (Contrasts-all-lev sequence))) + +2. Attribution of different weights to the datum points: +this step is crucial, because it strengthens the global hierarchy among the various analysis level in relation to the time parameter. + +(defun weights (sequence) + (mapcar #' (lambda (x) (apply '+ x)) + (Contrasts-all-lev sequence))) + +3. Application of weights to the distances: +this further step is just the application of different weights - obtained considering every time one of the events as datum point (global parameter, ex. nr. 3) +- to the distances between the various contiguous events (local parameter). + +(defun Contrasts-lev.1*weights (sequence) + (mapcar #' (lambda (x y) (om* y x)) + (distances sequence) (weights sequence))) + +;-------- + +(defun Contrasts-all-lev*weights (sequence) + (reverse (mapcar #' (lambda (xx) (apply '+ xx)) + (mat-trans (mapcar #' (lambda (x) (reverse x)) (Contrasts-lev.1*weights sequence)))))) + +A theoretical problem we have faced is the relation between the object we have analysed and the previous and following events. +Any events chain perceived as belonging to a whole and complete organism stays anyway in relation with the previous and following sequential chain. +In case of performance of a music piece, the silence acts as a frame of the structure, and, being a frame, it becomes organic element of the structure analysed. +It is worth to underline that even in case of extrapolation, like in the here quoted examples (a thematic fragment, a subject of a fugue, etc.), +the object is perceived as an unit, and therefore the silence places it in a well defined mental space. + +(x-append 'symbol-silence-start sequence 'symbol-silence-end) +" + :non-generic t + (let* ((sequence-whit-silence-start-end + (ompw-utils:x-append 'symbol-silence-start sequence + 'symbol-silence-end)) + (distances + (mapcar #'(lambda (x) (ompw-utils:x->dx x)) + (contrasts-all-lev sequence-whit-silence-start-end))) + (weights + (mapcar #'(lambda (x) (apply '+ x)) + (contrasts-all-lev sequence-whit-silence-start-end))) + (contrasts-lev.1*weights + (mapcar #'(lambda (x y) (ompw-utils:m* y x)) distances weights)) + (contrasts-all-lev*weights + (reverse (mapcar #'(lambda (xx) (apply '+ xx)) + (ompw-utils:mat-trans (mapcar + #'(lambda (x) (reverse x)) + contrasts-lev.1*weights)))))) + (butlast contrasts-all-lev*weights))) + + +(define-box energy-prof-morph-analysis (sequence) + :non-generic t + " +The step that allows to transform the New/Old Analysis function into a model able to simulate the psychic response of the perceptive act to the morphologic structure occurs using three functions. +Then, to this the three functions apply allowing to define the energy profile. +1. In the first passage, the transformation into absolute abs value contains all the relations with reference to the first element of the chain. +At this point, the data don't represent the ageing degree of the events anymore, but they are mere distance (it doesn't matter if they are old or new, they are to be intended nearly as physical distance between the various data stored in space/memory) related to a virtual point zero (a kind of possible present) +2. In the second passage, the use of the local derivative, implemented in OpenMusic under the name of x-->dx, the contiguous relations are again pointed out, and the distance identified in the first passage is assimilated to the energy needed to cover the contiguous distances in the space/memory +3 - Finally, the transformation into absolute abs value, because of the transformation of the distances into energy, brings all the data back to positive values. +" + :icon + 128 + (let* ((analysis-old-new (cons '0 (new-old-analysis sequence))) + (absolute-value (ompw-utils:m-abs analysis-old-new)) + (local-derivative (ompw-utils:x->dx absolute-value)) + (absolute-value2 (ompw-utils:m-abs local-derivative))) + absolute-value2))
(install-menu morphologie)
Modified: trunk/src/utils.lisp ============================================================================== --- trunk/src/utils.lisp (original) +++ trunk/src/utils.lisp Thu Aug 9 05:53:10 2007 @@ -27,6 +27,12 @@ res))) (nreverse res)))
+;;; TODO rename this to deep-sort-list +(defun sort-list (list &optional (pred '<)) + (cond ((null list) nil) + ((atom (first list)) (sort list pred)) + (t (cons (sort-list (first list) pred) (sort-list (rest list) pred))))) + (defun flat-once (list) (if (consp (car list)) (apply 'append list) list))