Author: ksprotte Date: Thu Jul 5 09:57:43 2007 New Revision: 10

Added: trunk/morphologie.asd trunk/src/tests.lisp Modified: trunk/src/morphologie.lisp Log: again some chs

Added: trunk/morphologie.asd ============================================================================== --- (empty file) +++ trunk/morphologie.asd Thu Jul 5 09:57:43 2007 @@ -0,0 +1,8 @@ +(in-package :asdf) + +(defsystem :morphologie + :components + ((:module :src + :components + ((:file "morphologie")))) + :depends-on (:ompw))

Modified: trunk/src/morphologie.lisp ============================================================================== --- trunk/src/morphologie.lisp (original) +++ trunk/src/morphologie.lisp Thu Jul 5 09:57:43 2007 @@ -13,9 +13,9 @@ ;;; please note that this file has been autogenerated ;;; hand editing might not yet make sense

-(defpackage "MORPH2" (:use :cl :ompw)) +(defpackage :morph2 (:use :cl :ompw))

-(in-package "MORPH2") +(in-package :morph2)

;;; watch out for functions like OM::group-list ;;; still in this file @@ -31,7 +31,7 @@ ;;; end utils

(define-ompw list-part (list &optional ncol) - "partitions <list> in <ncol> lists containing the elements modulo <ncol>" + "partitions LIST in NCOL lists containing the elements modulo NCOL" :non-generic t (let ((vector (make-array ncol)) res) (loop :while list @@ -50,8 +50,8 @@

(defun less-deep-mapcar (fun list? &rest args) - "Applies <fun> to <list?> <args> if <list?> is a one-level list . - Mapcars <fun> to <list?> <args> if <list?> is a multi-level list. " + "Applies FUN to LIST? ARGS if LIST? is a one-level list . + Mapcars FUN to LIST? ARGS if LIST? is a multi-level list. " (cond ((null list?) nil) ((atom (car list?)) (apply fun list? args)) ((atom (car (car list?))) @@ -62,7 +62,7 @@ (apply #'less-deep-mapcar fun (cdr list?) args)))))

(defun deep-mapcar (fun fun1 list? &rest args) - "Mapcars <fun> or applies <fun1> to <list?> <args> whether <list?> is a list or not." + "Mapcars FUN or applies FUN1 to LIST? ARGS whether LIST? is a list or not." (cond ((null list?) nil) ((not (consp list?)) (apply fun1 list? args)) (t @@ -75,12 +75,12 @@

(define-ompw g-min (list) :non-generic t - (less-deep-mapcar #'the-min (lib-utils::list! list))) + (less-deep-mapcar #'the-min (list! list)))

(define-ompw g-max (list) :non-generic t - (less-deep-mapcar #'the-max (lib-utils::list! list))) + (less-deep-mapcar #'the-max (list! list)))

(define-ompw l-nth (list l-nth) @@ -90,7 +90,7 @@

(define-ompw posn-match (list l-nth) :non-generic t - (deep-mapcar 'l-nth 'nth l-nth (lib-utils::list! list))) + (deep-mapcar 'l-nth 'nth l-nth (list! list)))

(define-ompw permut-circ (list &optional nth) @@ -186,23 +186,23 @@

(define-ompw ptrn-find ((list (1 2 3 1 2 3 1 2 1 2)) (n nil)) - "Donne tous les patterns de longueur <n> presents dans <list> + "Donne tous les patterns de longueur N presents dans LIST avec leur nombre d'occurences. - Est considere comme pattern tout segment de <list> + Est considere comme pattern tout segment de LIST repete au moins une fois. - Si <n> est nul (nil), donne tous les segments repetes quelle que + Si N est nul (nil), donne tous les segments repetes quelle que soit leur longueur; - <n> peut etre une liste de longueurs souhaitees." + N peut etre une liste de longueurs souhaitees." (error "default method. should not be called."))

(defmethod ptrn-find ((list list) (n integer)) - "Donne tous les patterns de longueur <n> presents dans <list> + "Donne tous les patterns de longueur N presents dans LIST avec leur nombre d'occurences. - Est considere comme pattern tout segment de <list> + Est considere comme pattern tout segment de LIST repete au moins une fois. - Si <n> est nul (nil), donne tous les segments repetes quelle que + Si N est nul (nil), donne tous les segments repetes quelle que soit leur longueur; - <n> peut etre une liste de longueurs souhaitees." + N peut etre une liste de longueurs souhaitees." (let* ((ris nil) (ros nil) (calcolo (ptrn-ridond-ctrl-prov list n)) @@ -235,10 +235,10 @@

(define-ompw ptrn-reson ((list (a b c a b c b b b b a a)) (windw 5) &optional (step nil) (set nil)) - "Avance dans la sequence <list> avec avec une taille de fenetre <windw> -et un pas d'avancement (optionnel) <step> . + "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. -L'entr�e optionnelle <set> specifie les segments recherches dans <list>." +L'entr�e optionnelle SET specifie les segments recherches dans LIST>" :non-generic t (count-ptrn-win list windw step set))

@@ -281,7 +281,7 @@ result-not-sorted)))))))

(define-ompw ptrn-smooth ((list (a b c d b b))) - "It returns the list <list> without local repetitions. + "It returns the list LIST without local repetitions. For example : list equal to (a a b c a b b c d c c) it reurns (a b c a b c d c))" :non-generic t @@ -336,21 +336,21 @@

(define-ompw find-permut ((seq nil) (output "permut") &optional (length nil) (ptrn nil)) - "Renvoie les permutations de deux elements de la sequence <seq>. - deux modes : <permutation> renvoie les segments d'elements permutes, <position> renvoie + "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. optionnels : -- <length> : longueur des segments. 2 par defaut. -- <ptrn> : segment dont les permutations sont recherch�s. -tous par d�faut. desactive <length>. +- LENGTH : longueur des segments. 2 par defaut. +- PTRN : segment dont les permutations sont recherch�s. +tous par d�faut. desactive LENGTH>

-Returns all permutations of two elements in <seq> with +Returns all permutations of two elements in SEQ with their respective positions in seq. Optional inputs : -<length>, length or list of lengths of segments to be permuted +LENGTH> length or list of lengths of segments to be permuted (if 'nil, length = 2); -<ptrn> : pattern of which permutations are looking for. - If not empty (nil), desactivates <length>." +PTRN : pattern of which permutations are looking for. + If not empty (nil), desactivates LENGTH>" :non-generic t :menu (output ("pos" "positions") ("permut" "permutations")) (assert (listp ptrn)) @@ -661,7 +661,7 @@ (dotimes (n (length seq)) (setf res2 (member (nth n seq) res1 :test 'equal)) (push (list res2 (second res2)) seq2)) - (lib-utils::mat-trans (reverse seq2)))) + (mat-trans (reverse seq2))))

(defun group (list) (let ((seqs (second list)) (a nil) (b nil) (c nil) (res nil)) @@ -669,7 +669,7 @@ (setf c (segnum1 s)) (setf a (remove-duplicates (OM::flat-once (car c)))) (setf b (cdr c)) - (setf a (lib-utils::mat-trans (reverse (list-modulo a 2)))) + (setf a (mat-trans (reverse (list-modulo a 2)))) (push (list a (car b)) res)) (list (car list) (reverse res))))

@@ -723,15 +723,15 @@ (format stream "~S " (nth n (cadr from-struct-1))) (format stream "~%~%"))))

-(define-ompw structure-1 ((seq nil) &optional (alpha? "alpha") (smooth? "yes") - (result "extend") (levels 1) (smth2? "no")) +(define-ompw structure-1 ((seq nil) &optional (alpha? :alpha) (smooth? :yes) + (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.

INPUT seq : s�quence de symboles ou nombres (liste); alpha? : r�sultat en mode alphab�tique ou num�rique (YES NO), optional; -lisse? : optional <yes> : suppression des elements repetes immediatements dans seq . +lisse? : optional YES : suppression des elements repetes immediatements dans seq . result : menu d�roulant, quatre possibilit�s : short = liste des crit�res de segmentation et leur segmentation respective; exten = analyse d�taill�e; @@ -744,19 +744,19 @@ ((crit�res de segmentation) (forme selon crit�re)...)" :non-generic t - :menu (alpha? ("alpha" "alpha") ("num" "num")) - :menu (smooth? ("yes" "yes") ("no" "no")) - :menu (result ("struct" "struct") ("short" "short") ("extend" "extend") - ("save" "save")) - :menu (smth2? ("yes" "yes") ("no" "no")) + :menu (alpha? :alpha :num) + :menu (smooth? :yes :no) + :menu (result :struct :short :extend + :save) + :menu (smth2? :yes :no) (assert (>= levels 1)) (if (> levels 1) - (rma-1 seq (if (equalp "yes" smooth?) 1 0) levels - (if (equalp "yes" smth2?) 1 0) (if (equalp "alpha" alpha?) 1 0) - (cond ((equalp result "struct") 3) - ((equalp result "short") 0) - ((equalp result "extend") 1) - ((equalp result "save") 2))) + (rma-1 seq (if (eql :yes smooth?) 1 0) levels + (if (eql :yes smth2?) 1 0) (if (eql :alpha alpha?) 1 0) + (cond ((eql :struct result) 3) + ((eql :short result) 0) + ((eql :extend result) 1) + ((eql :save result) 2))) (let ((lisse? smooth?) (seg nil) (res nil) @@ -764,14 +764,14 @@ (time-start (get-internal-real-time)) (run-time 0) out-file) - (when (equalp result "save") + (when (eql :save result) (setf out-file (choose-new-file-dialog :prompt "Structure-1 Mark Analysis" :button-string "save as"))) - (if (equalp lisse? "yes") + (if (eql :yes lisse?) (setf seg (group (seg/contrast (ptrn-smooth seq)))) (setf seg (group (seg/contrast seq)))) - (if (equalp alpha? "alpha") + (if (eql :alpha alpha?) (setf res (list (car seg) (to-alpha @@ -780,23 +780,23 @@ (setf run-time (float (/ (- (get-internal-real-time) time-start) internal-time-units-per-second))) - (cond ((equalp result "extend") + (cond ((eql :extend result) (view-str-1 seq res seg alpha? 't date run-time)) - ((equalp result "save") + ((eql :save result) (format t "Writing marker analysis in file : ~S...~%" out-file) (with-open-file (out-st out-file :direction :output :if-exists :supersede :if-does-not-exist :create) (view-str-1 seq res seg alpha? out-st date run-time)) (set-mac-file-creator out-file 'ttxt) (format t "DONE~%")) - ((equalp result "short") - (if (equalp alpha? "alpha") + ((eql :short result) + (if (eql :alpha alpha?) (to-a-special (list (car seg) (mapcar 'car (cadr seg)) (last res))) (list (car seg) (mapcar 'car (cadr seg)) (mapcar 'cadr (cadr seg))))) - ((equalp result "struct") (car (last res))))))) + ((eql :struct result) (car (last res)))))))

(defun take-structures (analysis) @@ -1097,7 +1097,7 @@ (alpha? 1) (result 0)) " m�me fonction que structure-1, mais r�cursive : -s'applique aussi aux structures trouv�es, avec <levels> +s'applique aussi aux structures trouv�es, avec LEVELS comme niveau de recursion. memes caract�ristiques que structure-1 Recursive Mark Analysis. Returns only found structures." @@ -1434,7 +1434,7 @@

(define-ompw 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 0)) - "Finds the pattern(s) <ptrn> in list seq with or without + "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. Doesn't permit cross-overing of a pattern on itself. @@ -1649,7 +1649,7 @@ (calcolaccio (dolist (k calcoletto (nreverse ros)) (push (OM::posn-match list-of-pat k) ros)))) - (lib-utils::mat-trans (list calcolo calcolaccio)))) + (mat-trans (list calcolo calcolaccio))))

(define-ompw forma ((analys nil) (seq nil) (seuil 1)) :non-generic t @@ -1672,12 +1672,12 @@ (dotimes (o (length anal)) (when (not (equal (member (nth n r2) (cadr (nth o anal))) 'nil)) (push (+ o 1) r1))))) - (cond ((equal alpha? 0) (lib-utils::mat-trans (list (reverse percent) r))) + (cond ((equal alpha? 0) (mat-trans (list (reverse percent) r))) ((= alpha? 1) - (lib-utils::mat-trans (list (reverse percent) - (dolist - (k r (reverse res)) - (push (to-alpha k) res)))))))) + (mat-trans (list (reverse percent) + (dolist + (k r (reverse res)) + (push (to-alpha k) res))))))))

(defun to-stream (seq list-of-pat seuil analysis compl stream date run-time) (format stream "~%****************************************~%") @@ -2446,7 +2446,7 @@ OM->(pure-flex- (8 2) (6 2) (2 3)) le premier chiffre indique la valeur r�p�t�e et le deuxi�me terme de la liste indique son nombre d'occurrences. -la deuxi�me entr�e est un menu <which> qui permet de selectionner +la deuxi�me entr�e est un menu WHICH qui permet de selectionner les informations: prim: succession des primitives prof: succession des primitives et profondeur en nombre d'�l�ments de @@ -2516,7 +2516,7 @@ (format t "~%ERROR !! different number of elements in the input list !!") (abort)) - ((reconst-prim list (lib-utils::list! start))))) + ((reconst-prim list (list! start))))) (2 (cond ((or (atom (car list)) (not (equalp (length (car list)) 2))) (format t @@ -2801,8 +2801,8 @@ "~%ERROR !! different number of parameters in the two lists !!") (abort))) (let* ((ris 0) - (matrix1 (lib-utils::mat-trans seq1)) - (matrix2 (lib-utils::mat-trans seq2)) + (matrix1 (mat-trans seq1)) + (matrix2 (mat-trans seq2)) (wgth (cond ((not (equalp (length wgth) (length (car seq1)))) (format t @@ -2827,8 +2827,8 @@ "~%ERROR !! different number of parameters in the two lists !!") (abort))) (let* ((ris 0) - (matrix1 (lib-utils::mat-trans seq1)) - (matrix2 (lib-utils::mat-trans seq2)) + (matrix1 (mat-trans seq1)) + (matrix2 (mat-trans seq2)) (wgth (cond ((not (equalp (length wgth) (length (car seq1)))) (format t @@ -3094,8 +3094,8 @@ (define-ompw notes-change ((pits 6000) (scale 6000) &optional (mod 12)) "Cambia un p^rofilo con le note messe in scale." :non-generic t - (let* ((pits (lib-utils::list! pits)) - (scale (lib-utils::list! scale)) + (let* ((pits (list! pits)) + (scale (list! scale)) (modsca (OM::om// (OM::sort-list @@ -3121,7 +3121,7 @@ (define-ompw octave ((midic 6000)) "retourne l'octave � partir de c3=octave 3" :non-generic t - (let ((midic (lib-utils::list! midic))) + (let ((midic (list! midic))) (mapcar #'(lambda (x) (OM::om- (OM::om// x 1200) 2)) midic)))

@@ -3150,14 +3150,14 @@ (let ((ris nil) (y (lettura-modulare list1 list2))) (OM::flat (append (dotimes (x (1- (length list1)) (nreverse ris)) - (push (lib-utils::mat-trans (list - (list (nth x list1)) - (list - (trans-approx - (list (nth x y)) - (list - (nth x list1) - (nth (1+ x) list1)))))) + (push (mat-trans (list + (list (nth x list1)) + (list + (trans-approx + (list (nth x y)) + (list + (nth x list1) + (nth (1+ x) list1)))))) ris)) (last list1)))))

@@ -3193,17 +3193,17 @@ (let ((ris nil) (y (lettura-modulare list1 list2))) (OM::flat (append (dotimes (x (1- (length list1)) (nreverse ris)) - (push (lib-utils::mat-trans (list - (list (nth x list1)) - (list - (OM::om+ - (OM::nth-random - (list 1200 0 -1200)) - (trans-approx - (list (nth x y)) - (list - (nth x list1) - (nth (1+ x) list1))))))) + (push (mat-trans (list + (list (nth x list1)) + (list + (OM::om+ + (OM::nth-random + (list 1200 0 -1200)) + (trans-approx + (list (nth x y)) + (list + (nth x list1) + (nth (1+ x) list1))))))) ris)) (last list1)))))

@@ -3337,7 +3337,7 @@ (define-ompw malt-mod+ ((list nil) (limit 6000)) "" :non-generic t - (let ((ris nil) (limite (first (lib-utils::list! limit)))) + (let ((ris nil) (limite (first (list! limit)))) (dolist (y list (nreverse ris)) (push (if (< y limite) (- (* 2 limite) y) y) ris))))

@@ -3350,7 +3350,7 @@ (define-ompw malt-mod- ((list nil) (limit 6000)) "" :non-generic t - (let ((ris nil) (limite (first (lib-utils::list! limit)))) + (let ((ris nil) (limite (first (list! limit)))) (dolist (y list (nreverse ris)) (push (if (> y limite) (- (* 2 limite) y) y) ris))))

@@ -3369,7 +3369,7 @@

(defun mod-fix- (ls asse) "" - (let ((ris nil) (asse (lib-utils::list! asse))) + (let ((ris nil) (asse (list! asse))) (dotimes (x (length ls) (nreverse ris)) (push (if (<= (nth x ls) (first asse)) (nth x ls) @@ -3379,7 +3379,7 @@

(defun mod-fix+ (ls asse) "" - (let ((ris nil) (asse (lib-utils::list! asse))) + (let ((ris nil) (asse (list! asse))) (dotimes (x (length ls) (nreverse ris)) (push (if (>= (nth x ls) (first asse)) (nth x ls) @@ -3388,8 +3388,8 @@ ris))))

(define-ompw reflex-note ((ls nil) (value 0) (up/down 1)) - "Restituisce per la riflessione superiore con <UP> e quella - inferiore con <DOWN>." + "Restituisce per la riflessione superiore con UP e quella + inferiore con DOWN>" :non-generic t :menu (up/down (1 "up") (2 "down")) (case up/down @@ -3399,14 +3399,14 @@

(define-ompw doppio-reflex-note ((list nil) (value nil)) - "Restituisce due volte <REFLEX-NOTE> la prima volta a <LIST> + "Restituisce due volte REFLEX-NOTE la prima volta a LIST la seconda volta al risultato della prima volta." :non-generic t (reflex-note (reflex-note list (g-min value) 1) (g-max value) 2))

(define-ompw doppio-reflex-int ((list nil) (value nil)) - "Restituisce due volte <REFLEX-INT> la prima volta a <LIST> + "Restituisce due volte REFLEX-INT la prima volta a LIST la seconda volta al risultato della prima volta." :non-generic t (reflex-int (reflex-int list (g-min value) 1) (g-max value) 2)) @@ -3424,7 +3424,7 @@

(define-ompw correttore-doppio-reflex-note ((list nil) (value nil) (inclu? 1)) "Corregge il risultato di 'DOPPIO-REFLEX-NOTE' in modo che se la - riflessione supera i limiti con <YES> abbiamo una trasposizione + riflessione supera i limiti con YES abbiamo una trasposizione oltre i limiti stessi ma con TRANS-APPROX altrimenti le note che non sono incluse nei limiti vengono escluse dalla funzione COMP-OCTAVE." @@ -3447,7 +3447,7 @@ (dolist (y risultato (OM::flat (nreverse ris))) (push (if (int y value) y - (correttore-doppio-reflex-int (lib-utils::list! (1+ y)) value)) + (correttore-doppio-reflex-int (list! (1+ y)) value)) ris))))

@@ -3487,13 +3487,13 @@

(define-ompw rtm-change ((rhyt nil) (modulo nil) (mode? 1)) - "E' la funzione che cambia un ritmo in funzione del menu <mode?> - Se <mode?> � su mod, questa funzione restituisce i multipli - dei valori in <moduli>; se � su ptrn allora retituisce una - struttura ritmica che utlilizza solamente i valori in <modulo>" + "E' la funzione che cambia un ritmo in funzione del menu MODE? + Se MODE? � su mod, questa funzione restituisce i multipli + dei valori in MODULI; se � su ptrn allora retituisce una + struttura ritmica che utlilizza solamente i valori in MODULO" :non-generic t :menu (mode? (1 "mod") (2 "ptrn")) - (let ((modulo (lib-utils::list! modulo))) + (let ((modulo (list! modulo))) (case mode? (1 (substitute (g-min modulo) 0.0 (usa-quel-modulo rhyt modulo))) (2 (rtm-change-1 rhyt modulo)) @@ -3507,7 +3507,7 @@ lista di valori allora approssima tutti i valori in rtm con i valori di vals." :non-generic t - (let ((vals (lib-utils::list! vals))) (vicini-valori vals rhytm))) + (let ((vals (list! vals))) (vicini-valori vals rhytm)))

(define-ompw distanza-modulo ((list nil) (modulo nil)) @@ -3526,7 +3526,7 @@ :non-generic t (let ((ris nil) (calcolo (distanza-modulo list (OM::om-abs moduli)))) (dotimes (x (length list) (nreverse ris)) - (if (subsetp (list 0) (lib-utils::list! (nth x calcolo)) :test #'equal) + (if (subsetp (list 0) (list! (nth x calcolo)) :test #'equal) (push (nth x list) ris) (push (- (nth x list) (g-min (nth x calcolo))) ris)))))

@@ -3582,7 +3582,7 @@

(define-ompw arithm-ser2 ((begin 0) (step 1) (xval 5)) - "Returns a list of <xval> numbers starting from <begin> with <step>." + "Returns a list of XVAL numbers starting from BEGIN with STEP." :non-generic t (algeb begin xval step))

@@ -3620,7 +3620,7 @@ (push f dates) (push time f0))) (t (dotimes (g 2) (read input-stream))))) - (lib-utils::mat-trans (list (reverse dates) (reverse f0)))))) + (mat-trans (list (reverse dates) (reverse f0))))))

(define-ompw pi-dur ((dates nil) (pitches nil) (min 0) (unit 1)) @@ -3901,12 +3901,12 @@ (define-ompw draw-tree ((tree nil) &optional (nodes nil) (name nil) (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. +TREE : a tree list from Prim-tree. Optional arguments : -<name> : window name (string or symbol without white spaces); -<fontname> : a menu to specify font name; -<fontsize> : a menu to specify the font size; -<fontstyle> : a menu to specify bold or normal. +NAME : window name (string or symbol without white spaces); +FONTNAME : a menu to specify font name; +FONTSIZE : a menu to specify the font size; +FONTSTYLE : a menu to specify bold or normal. Default is Times 12 normal." :non-generic t :menu (fontname ("geneva" "Geneva") ("helvetica" "Helvetica") @@ -4420,8 +4420,8 @@ (lul1 (append (list (lul (car ldl) (cadr ldl))) (cddr ldl)))))

(define-ompw tree-path ((tree nil) (start nil) (end nil)) - "Finds all paths in prim-tree <tree> from <start> to <end>. -Both <start> end <end> can be atoms (number, symbols or strings according to the tree) + "Finds all paths in prim-tree TREE from START to END> +Both START end END can be atoms (number, symbols or strings according to the tree) or lists of atoms. If no start and/or end are specified, returns all possible solutions (paths)." :non-generic t

Added: trunk/src/tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests.lisp Thu Jul 5 09:57:43 2007 @@ -0,0 +1,8 @@ +(in-package :morph2) + +(ptrn-find '(1 2 3 1 2 3 1 2 1 2) nil) +(ptrn-reson '(a b c a b c b b b b a a) 5) +(ptrn-smooth '(a b c d b b)) + +(structure-1 '(a b c a b c d a c c d a a b c a)) +