July 2007 - morphologie-cvs@common-lisp.net

[Morphologie-cvs] r25 - trunk/src
by ksprotte＠common-lisp.net 20 Jul '07

20 Jul '07

Author: ksprotte Date: Fri Jul 20 11:17:04 2007 New Revision: 25 Modified: trunk/src/morphologie.lisp Log: I changed ES to DS Modified: trunk/src/morphologie.lisp ============================================================================== --- trunk/src/morphologie.lisp (original) +++ trunk/src/morphologie.lisp Fri Jul 20 11:17:04 2007 @@ -601,7 +601,7 @@ "~D~D" (nth note-number '("C" "CN+" "CS--" "CS-" "CS" "CS+" "CS++" "DN-" "D" - "DN+" "DS--" "DS-" "ES" "DS+" "DS++" "EN-" "E" "EN+" + "DN+" "DS--" "DS-" "DS" "DS+" "DS++" "EN-" "E" "EN+" "ES--" "ES-" "F" "FN+" "FS--" "FS-" "FS" "FS+" "FS++" "GN-" "G" "GN+" "GS--" "GS-" "GS" "GS+" "GS++" "AN-" "A" "AN+" "AS--" "AS-" "BF" "AS+" "AS++" "BN-" "B"

1 0

[Morphologie-cvs] r24 - trunk/src
by ksprotte＠common-lisp.net 20 Jul '07

20 Jul '07

Author: ksprotte Date: Fri Jul 20 10:46:59 2007 New Revision: 24 Modified: trunk/src/morphologie.lisp Log: small fix to mc->alpha; also (intern ... "MORPH") Modified: trunk/src/morphologie.lisp ============================================================================== --- trunk/src/morphologie.lisp (original) +++ trunk/src/morphologie.lisp Fri Jul 20 10:46:59 2007 @@ -607,7 +607,7 @@ "A" "AN+" "AS--" "AS-" "BF" "AS+" "AS++" "BN-" "B" "BN+" "BS--" "BS-")) octave-number) - "MORPH2"))) + "MORPH"))) (defun mc-to-name (midicents &optional (approx 0)) @@ -628,7 +628,7 @@ (define-box mc->alpha ((midicents nil) approx) :non-generic t - (mc->alpha midicents approx)) + (mc->alpha1 midicents approx)) (define-box concatstrings ((lofstrings nil))

1 0

[Morphologie-cvs] r23 - in trunk: . src
by ksprotte＠common-lisp.net 15 Jul '07

15 Jul '07

Author: ksprotte Date: Sun Jul 15 10:27:06 2007 New Revision: 23 Modified: trunk/morphologie.asd trunk/src/morphologie.lisp trunk/src/utils.lisp Log: file-dialog and external-format :latin-1 Modified: trunk/morphologie.asd ============================================================================== --- trunk/morphologie.asd (original) +++ trunk/morphologie.asd Sun Jul 15 10:27:06 2007 @@ -1,5 +1,8 @@ (in-package :asdf) +;; This is a hack to read latin-1 instead of utf-8 +#+sbcl (setq sb-impl::*default-external-format* :latin-1) + (defsystem :morphologie :version "3.0" :components Modified: trunk/src/morphologie.lisp ============================================================================== --- trunk/src/morphologie.lisp (original) +++ trunk/src/morphologie.lisp Sun Jul 15 10:27:06 2007 @@ -5,12 +5,15 @@ ;;;* IRCAM, Paris, november 1998 for Morphologie 1.0 * ;;;* may 1999 for Morphologie 2.0 * ;;;* * -;;;* Fonctions d'analyse, reconnaissance de pattern et classification morphologiques des profiles géometriques * +;;;* Fonctions d'analyse, reconnaissance de pattern et classification morphologiques des profiles g�ometriques * ;;;* Analysis fonctions, pattern recognition and morphological classification of geometric profiles * ;;;* * ;;;************************************************************************************************************* ;;; +;;; the encoding of this file is latin-1 +;;; that's the best common demoninator + (in-package :morph) ;;; watch out for functions like OM::.... @@ -142,7 +145,7 @@ (define-box pattern-ridond ((lista nil) &optional (n nil)) "Restituisce tutte le ripetizioni di tutti i sotto-pattern in - cui può essere scomposta la sequenza in lista." + cui pu� essere scomposta la sequenza in lista." :non-generic t (let ((ris nil) (x (scom lista n)) y) (loop :while x @@ -244,8 +247,8 @@ (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. -L'entrée optionnelle SET specifie les segments recherches dans LIST>" +Renvoie pour chaque fen�tre le nombre d'occurrences d'un �l�ment. +L'entr�e optionnelle SET specifie les segments recherches dans LIST>" :non-generic t (count-ptrn-win list windw step set)) @@ -348,8 +351,8 @@ 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> +- PTRN : segment dont les permutations sont recherch�s. +tous par d�faut. desactive LENGTH> Returns all permutations of two elements in SEQ with their respective positions in seq. @@ -446,7 +449,7 @@ (defparameter **alpha** (quote (#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z - #\°))) + #\�))) (defparameter **num** (quote (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))) @@ -736,24 +739,24 @@ (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)) - "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. + "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; +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 . -result : menu déroulant, quatre possibilités : - short = liste des critères de segmentation et leur segmentation respective; - exten = analyse détaillée; +result : menu d�roulant, quatre possibilit�s : + short = liste des crit�res de segmentation et leur segmentation respective; + exten = analyse d�taill�e; - save = analyse détaillée écrite en un fichier texte. + save = analyse d�taill�e �crite en un fichier texte. OUTPUT en mode short, pour le traitement de l'analyse, liste de liste selon le format : -\((critères de segmentation) -\(forme selon critère)...)" +\((crit�res de segmentation) +\(forme selon crit�re)...)" :non-generic t :menu (alpha? :alpha :num) :menu (smooth? :yes :no) @@ -1111,10 +1114,10 @@ (define-box rma-1 ((seq nil) (smoo1 1) (levels 1) &optional (smoo2 0) (alpha? 1) (result 0)) " -même fonction que structure-1, mais récursive : -s'applique aussi aux structures trouvées, avec LEVELS +m�me fonction que structure-1, mais r�cursive : +s'applique aussi aux structures trouv�es, avec LEVELS comme niveau de recursion. -memes caractéristiques que structure-1 +memes caract�ristiques que structure-1 Recursive Mark Analysis. Returns only found structures." :non-generic t (when (< levels 1) @@ -1874,7 +1877,7 @@ The classe number is arbitrary" (class-1 (l-matrix matrix) n alpha? centers verbose)) -(defun CENTRE-GRAVIT\é (x) +(defun CENTRE-GRAVIT\� (x) (let (sum g (n (nth 1 (array-dimensions x))) @@ -1886,9 +1889,9 @@ (setf (aref g 0 i) (float (/ sum m)))))) (define-box matrix-center ((matrix nil)) - "Donne les coordonnées du centre de gravité d'une matrice - des coordonnées de points en n-dimensions (utiliser l-matrix -pour convertir une liste de coordonnées de points en matrice). + "Donne les coordonn�es du centre de gravit� d'une matrice + des coordonn�es de points en n-dimensions (utiliser l-matrix +pour convertir une liste de coordonn�es de points en matrice). " :non-generic t (let (sum @@ -1902,18 +1905,18 @@ (setf (aref g 0 i) (float (/ sum m)))))) -(defun X-CENTR\éE (x) - (let ((g (CENTRE-GRAVIT\é x)) +(defun X-CENTR\�E (x) + (let ((g (CENTRE-GRAVIT\� x)) (n (nth 1 (array-dimensions x))) (m (nth 0 (array-dimensions x))) - CENTR\éE) - (setq CENTR\éE (make-array (list m n))) - (dotimes (i m CENTR\éE) - (dotimes (j n) (setf (aref CENTR\éE i j) (aref g 0 j)))) - (setf CENTR\éE (subtract-two-matrices x CENTR\éE)))) + CENTR\�E) + (setq CENTR\�E (make-array (list m n))) + (dotimes (i m CENTR\�E) + (dotimes (j n) (setf (aref CENTR\�E i j) (aref g 0 j)))) + (setf CENTR\�E (subtract-two-matrices x CENTR\�E)))) (defun dist-grav (x) - (let ((grav (CENTRE-GRAVIT\é x)) + (let ((grav (CENTRE-GRAVIT\� x)) d-grav diff (m (nth 0 (array-dimensions x))) @@ -1989,7 +1992,7 @@ collect (aref mat-dist i j))))) (defun rand-classes (m n) - "crée une m-liste aléatoire de n nombres différents" + "cr�e une m-liste al�atoire de n nombres diff�rents" (let ((alea nil) (alea-test nil)) (dotimes (a m alea) (push (random n) alea)) (setf alea-test (remove-duplicates alea)) @@ -1997,7 +2000,7 @@ (defun centre-classes (x classes *m* *n* *n-cl*) "input = matrice des points - liste-vecteur des classes attribuées à chaque point + liste-vecteur des classes attribu�es � chaque point output = matrice des centres de chaque classe" (let (nuage point c tc centres) (setf centres (make-array (list *n-cl* *n*))) @@ -2012,7 +2015,7 @@ (cond ((eq (nth a classes) b) (setf point (+ point 1)) (dotimes (d *n*) (setf (aref nuage (- point 1) d) (aref x a d))) - (setf tc (CENTRE-GRAVIT\é nuage))))) + (setf tc (CENTRE-GRAVIT\� nuage))))) (dotimes (d *n*) (setf (aref centres b d) (aref tc 0 d)))))) (define-box class-center ((matrix nil) (classes nil)) @@ -2042,7 +2045,7 @@ (setf point (+ point 1)) (dotimes (d *n*) (setf (aref nuage (- point 1) d) (aref matrix a d))) - (setf tc (CENTRE-GRAVIT\é nuage))))) + (setf tc (CENTRE-GRAVIT\� nuage))))) (dotimes (d *n*) (setf (aref centres b d) (aref tc 0 d)))))) @@ -2066,7 +2069,7 @@ data : list of classes distribution (typically data from class-1; OUT Shannon entropie value, 0 <= entropie <= (log n 2). -Cf. J. Wasemberg : L âme de la méduse, idées sur la complexité du monde, +Cf. J. Wasemberg : L �me de la m�duse, id�es sur la complexit� du monde, Seuil, Paris, 1997." (let ((cl (remove-duplicates data)) (n (length data)) (p nil)) (dolist (ci cl (- 0 (apply #'+ (mapcar #'(lambda (x) (* x (log x 2))) p)))) @@ -2081,7 +2084,7 @@ Shannon entropie value 0 <= entropy <= (log n 2) if res = absolute; 0 <= entropy <= 1.0 if res = relative. -Cf. J. Wasemberg : L âme de la méduse, idées sur la complexité du monde, +Cf. J. Wasemberg : L �me de la m�duse, id�es sur la complexit� du monde, Seuil, Paris, 1997." :menu (res (:abs "absolute") (:rel "relative")) (declare (ignore class res)) @@ -2095,7 +2098,7 @@ Shannon entropie value 0 <= entropy <= (log n 2) if res = absolute; 0 <= entropy <= 1.0 if res = relative. -Cf. J. Wasemberg : L âme de la méduse, idées sur la complexité du monde, +Cf. J. Wasemberg : L �me de la m�duse, id�es sur la complexit� du monde, Seuil, Paris, 1997." (cond ((not (member 'nil (mapcar #'atom class))) (if (equalp res :abs) (setf res 1) (setf res 0)) @@ -2117,7 +2120,7 @@ Shannon entropie value 0 <= entropy <= (log n 2) if res = absolute; 0 <= entropy <= 1.0 if res = relative. -Cf. J. Wasemberg : L âme de la méduse, idées sur la complexité du monde, +Cf. J. Wasemberg : L �me de la m�duse, id�es sur la complexit� du monde, Seuil, Paris, 1997." (setf class (str->symb class)) (entropy class res)) @@ -2148,8 +2151,8 @@ (defun normalize-class (classes) "reordonne les classes de class-1. -L'ordre de la classe étant le numéro de sa première occurence dans la liste des classes. -Se connecte typiquement après class-1 ou meta-class1." +L'ordre de la classe �tant le num�ro de sa premi�re occurence dans la liste des classes. +Se connecte typiquement apr�s class-1 ou meta-class1." (let ((set nil) (r nil) (marker -1) (tempset nil) n) (when (stringp classes) (setf classes (str->symb classes))) (setf n (length (remove-duplicates classes))) @@ -2164,8 +2167,8 @@ (define-box norm-class ((classes nil)) "reordonne les classes de class-1. -L'ordre de la classe étant le numéro de sa première occurence dans la liste des classes. -Se connecte typiquement après class-1 ou meta-class1. +L'ordre de la classe �tant le num�ro de sa premi�re occurence dans la liste des classes. +Se connecte typiquement apr�s class-1 ou meta-class1. IN : string or list (of symbols or lists or strings)." :non-generic t (if (or (stringp classes) (not (listp (car classes)))) @@ -2453,23 +2456,23 @@ 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 +minima: element pr�c�d� et suivi par un �l�ment de valeur plus grande. -maxima: element précédé et suivi par un élément +maxima: element pr�c�d� et suivi par un �l�ment de valeur plus petite -flex: element précédé et suivi par un élément -de valeur égale +flex: element pr�c�d� et suivi par un �l�ment +de valeur �gale ex : (10 8 8 6 6 5 2 2 2 1) 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 +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 les informations: prim: succession des primitives -prof: succession des primitives et profondeur en nombre d'éléments de +prof: succession des primitives et profondeur en nombre d'�l�ments de chaque primitive -vals: idem que prof + valeur correspondant à chaque primitive +vals: idem que prof + valeur correspondant � chaque primitive every: idem que vals + position de chaque primitive" :non-generic t :menu (result (1 "prim") (2 "prof") (3 "vals") (4 "every")) @@ -2495,7 +2498,7 @@ (define-box 1-0-1-reconst ((list nil)) "fonction dx->x d'OM : renvoie une liste de points depuis une liste - d'intervalles . commence à zero" + d'intervalles . commence � zero" :non-generic t (OM::dx->x 0 list)) @@ -2558,7 +2561,7 @@ (define-box reconst-prim+prof ((list nil)) "Ricostruisce la lista usando min, max, flex - più eventualmente l'indice di profondità" + pi� eventualmente l'indice di profondit�" :non-generic t (let ((ris nil) (start 0)) (dolist (y list @@ -2580,8 +2583,8 @@ ris)))) -(defun rec-st-2 (struct |N°| &optional seq) - (let* ((rs (nth |N°| struct)) +(defun rec-st-2 (struct |N�| &optional seq) + (let* ((rs (nth |N�| struct)) (risultato (mapcar #'(lambda (x) (OM::flat (nth x (cadr rs)))) (mapcar #'1- (cadar rs))))) @@ -2590,27 +2593,27 @@ (OM::flat risultato)))) (define-box struct2-to-seq ((struct nil) (n nil) &optional ptrns) - "Reconstruit une séquence correspondant à la structure donnée en struct. - Optional : reconstruit une séquence de même structure avec les patterns - donnés en ptrns." + "Reconstruit une s�quence correspondant � la structure donn�e en struct. + Optional : reconstruit une s�quence de m�me structure avec les patterns + donn�s en ptrns." (declare (ignore struct n)) (error "default method. should not be called.")) (defmethod struct2-to-seq ((struct list) (n integer) &optional ptrns) - "Reconstruit une séquence correspondant à la structure donnée en struct. - Optional : reconstruit une séquence de même structure avec les patterns - donnés en ptrns." + "Reconstruit une s�quence correspondant � la structure donn�e en struct. + Optional : reconstruit une s�quence de m�me structure avec les patterns + donn�s en ptrns." (rec-st-2 struct n ptrns)) (defmethod struct2-to-seq ((struct list) (n list) &optional ptrns) - "Reconstruit une séquence correspondant à la structure donnée en struct. - Optional : reconstruit une séquence de même structure avec les patterns - donnés en ptrns." + "Reconstruit une s�quence correspondant � la structure donn�e en struct. + Optional : reconstruit une s�quence de m�me structure avec les patterns + donn�s en ptrns." (mapcar #'(lambda (i) (rec-st-2 struct i ptrns)) n)) (define-box reconst-prim+prof+val ((list nil) (start 6000)) "Ricostruisce la lista usando min, max, flex - più eventualmente l'indice di profondità" + pi� eventualmente l'indice di profondit�" :non-generic t (let ((ris nil)) (dotimes (x (length list) (OM::flat (nreverse ris))) @@ -2640,7 +2643,7 @@ (define-box pos+prim+prof+val ((list nil) (start 6000)) "Ricostruisce la lista usando min, max, flex - più eventualmente l'indice di profondità" + pi� eventualmente l'indice di profondit�" :non-generic t (let ((ris nil) (valore nil)) (dotimes (x (length list) @@ -2722,7 +2725,7 @@ (define-box controlla-ottave ((list1 nil) (list2 nil) (modul 12)) "studia i casi particolari della melodia in questione se questa - è trasposta più o meno esattamente" + � trasposta pi� o meno esattamente" :non-generic t (let* ((ris nil) (ros nil) @@ -2993,9 +2996,9 @@ (define-box multi-distance ((seq1 nil) (seq2 nil) (change 1) (ins/sup 1) (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." + "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." :non-generic t (if inex (dist-2-ldl seq1 seq2 change ins/sup inex wgth) @@ -3024,8 +3027,8 @@ (define-box resemblance ((a nil) (b nil) (wocc 1.0) (wref 1.0) &optional (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. + "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; Wref : poids de la structure de repetition." :menu (diff :res :diss) @@ -3034,8 +3037,8 @@ (defmethod resemblance ((a list) (b list) (wocc float) (wref float) &optional diff) - "Calcule une valeur de ressemblance entre 0 et 100 entre deux séquences -de symboles selon le critère de leur structure interne. + "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; Wref : poids de la structure de repetition." (let* ((ma (resemblance-match a a)) @@ -3076,13 +3079,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))) @@ -3103,13 +3106,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)) @@ -3140,7 +3143,7 @@ (define-box octave ((midic 6000)) - "retourne l'octave à partir de c3=octave 3" + "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)) @@ -3148,14 +3151,14 @@ (define-box makenote ((index 60) (octave 3) &optional (mod 12)) - " construction d'une note à partir des données + " construction d'une note � partir des donn�es de index, octave e modulo du index" :non-generic t (+ (/ (* index 100 12) mod) (* (+ 2 octave) 1200))) (defun lettura-modulare (lista1 lista2) - "Se la prima lista è più grande della seconda lista, allora legge + "Se la prima lista � pi� grande della seconda lista, allora legge modularmente la seconda lista restituendo un length uguale al length di lista1." (let ((ros nil)) @@ -3184,10 +3187,10 @@ (define-box prof-inter ((list1 nil) (list2 nil) (total 1)) - "Restituisce l'interposizione di list1 con list2. Se list1 è più piccola + "Restituisce l'interposizione di list1 con list2. Se list1 � pi� piccola di list2 allora la funzione crea un'interposizione di n elementi di list2 dove (= n (- (length list1) 1)). In questo caso si puo' decidere con il - menù se avere la prima ricorsione per completare list2." + men� se avere la prima ricorsione per completare list2." :non-generic t :menu (total (1 "ltd") (2 "copl")) (case total @@ -3198,14 +3201,14 @@ (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) + (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)))) + (permut-circ list2 (1- (length list1))) (- GR\� 1)))) (define-box new-inter-profile ((list1 nil) (list2 nil)) @@ -3229,14 +3232,14 @@ (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) + (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)))) + (permut-circ list2 (1- (length list1))) (- GR\� 1)))) (defun int-com-ottava (lista) @@ -3279,9 +3282,9 @@ (define-box correttore ((elmt 1) (range nil)) "Restituisce un elemento se questo compare all'interno del range. - Se l'elemento è escluso allora lo traspone in modo tale che sia - il più vicino possibile o al limite superiore o a quello inferiore. - Se il limite è DO-SOL allora Mi viene incluso, SI viene trasposto + Se l'elemento � escluso allora lo traspone in modo tale che sia + il pi� vicino possibile o al limite superiore o a quello inferiore. + Se il limite � DO-SOL allora Mi viene incluso, SI viene trasposto sotto il DO e il SOL# viene trasposto sopra il SOL." :non-generic t (let ((max (g-max range)) (min (g-min range))) @@ -3297,26 +3300,26 @@ (defun cor-ott-list (elmt range) "Restituisce un elemento se questo compare all'interno del range. - Se l'elemento è escluso allora lo traspone in modo tale che sia - il più vicino possibile o al limite superiore o a quello inferiore. - Se il limite è DO-SOL allora Mi viene incluso, SI viene trasposto + Se l'elemento � escluso allora lo traspone in modo tale che sia + il pi� vicino possibile o al limite superiore o a quello inferiore. + Se il limite � DO-SOL allora Mi viene incluso, SI viene trasposto sotto il DO e il SOL# viene trasposto sopra il SOL.La differenza - con 'CORRETTORE' è che questo modulo agisce su una lista intera." + con 'CORRETTORE' � che questo modulo agisce su una lista intera." (let ((ris nil)) (dolist (y elmt) (push (correttore y range) ris)) (nreverse ris))) (define-box trans-approx ((list nil) (range nil)) "E' meglio di transpoct di Esquisse. Infatti attua lo stesso - procedimento ma traspone una nota non inclusa nel range il più + procedimento ma traspone una nota non inclusa nel range il pi� vicino o al limite superiore o a quello inferiore." :non-generic t (cor-ott-list (mio-transpoct list range) range)) (define-box direct-analysis ((list (6000 4000 6900 7300 6100 5900))) - "donne le signe de la dérivée locale (-1. 0 +1) pour chaque point de la liste -des valeurs données en entrée." + "donne le signe de la d�riv�e locale (-1. 0 +1) pour chaque point de la liste +des valeurs donn�es en entr�e." :non-generic t (let ((ris nil)) (dotimes (x (length (OM::x->dx list)) (nreverse ris)) @@ -3364,8 +3367,8 @@ (defun interno (elmt range) - "Restituisce l'elemento se è incluso nel 'range' e nil - se non è incluso." + "Restituisce l'elemento se � incluso nel 'range' e nil + se non � incluso." (if (<= (g-min range) elmt (g-max range)) elmt nil)) (define-box malt-mod- ((list nil) (limit 6000)) @@ -3378,7 +3381,7 @@ (define-box reflex-int ((ls nil) (value 0) (up/down 1)) "Restituisce la rifleesione delle note che sono superiori o inferiori - al valore indicato con 'value'. Il menù permette di selezionare se si + al valore indicato con 'value'. Il men� permette di selezionare se si vuole una riflessione superiore o inferiore" :non-generic t :menu (up/down (1 "up") (2 "down")) @@ -3499,7 +3502,7 @@ (define-box comp-octave ((list nil) (range nil)) "Restituisce una trasposizione della lista mantenendo le altezze - assolute all'interno del 'range. Se un elemento non è incluso + assolute all'interno del 'range. Se un elemento non � incluso nel 'range', allora viene tolto dal risultato." :non-generic t (let ((ris nil)) @@ -3509,8 +3512,8 @@ (define-box 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 + 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")) @@ -3522,9 +3525,9 @@ (define-box rtm-change-1 ((rhytm nil) (vals nil)) - "Se in vals c'è un solo valore allora calcola una + "Se in vals c'� un solo valore allora calcola una approssimazione ritmica in modo tale che tutti i valori - risultino un multiplo di vals. Se invece in vals c'è una + risultino un multiplo di vals. Se invece in vals c'� una lista di valori allora approssima tutti i valori in rtm con i valori di vals." :non-generic t @@ -3554,8 +3557,8 @@ (define-box rtm-change-1val ((rht nil) (val 1)) "Questa funzione prende ogni elemento di rht e restituisce - lo stesso elemento se il (mod rht val) è uguale a 0 - altrimenti lo approssima al poù vicino" + lo stesso elemento se il (mod rht val) � uguale a 0 + altrimenti lo approssima al po� vicino" :non-generic t (let ((ris nil)) (dolist (y rht (nreverse ris)) @@ -3576,13 +3579,13 @@ (define-box segno+picc ((list nil)) "Trasforma tutta la lista in valori tutti positivi e prende il valore - più piccolo." + pi� piccolo." :non-generic t (g-min (mapcar #'(lambda (x) (abs x)) list))) (define-box nota-vicina ((list nil) (ref 1)) - "Prende l'intervallo più piccolo di una lista." + "Prende l'intervallo pi� piccolo di una lista." :non-generic t (let* ((intervalli (tutti-int list ref)) (piccolo (segno+picc intervalli))) (if (equalp (abs (first intervalli)) piccolo) @@ -3591,13 +3594,13 @@ (define-box tieni-nota ((list nil) (ref 1)) - "tiene la nota più vicina." + "tiene la nota pi� vicina." :non-generic t (OM::om+ ref (nota-vicina list ref))) (define-box vicini-valori ((list1 nil) (refs nil)) - "Prende le note più vicine di list per ogni nota di refs." + "Prende le note pi� vicine di list per ogni nota di refs." :non-generic t (mapcar #'(lambda (x) (tieni-nota list1 x)) refs)) @@ -3798,8 +3801,8 @@ (define-box prim-tree ((dist nil)) "Builds up the shorter tree of the points given in the matrix of distances (list of list), distances must be expressed as ((xi yi di) etc.). -prend en entrée la sortie de ldl-distance en mode extend. -See: E. Diday & all, 1982 : Elements d'analyse de données, Dunod, Paris. pp. 110-111." +prend en entr�e la sortie de ldl-distance en mode extend. +See: E. Diday & all, 1982 : Elements d'analyse de donn�es, Dunod, Paris. pp. 110-111." :non-generic t (assert (not (member 0 dist :test #'equalp :key #'third)) nil @@ -3906,7 +3909,7 @@ (define-box delta ((list nil) (round 1000)) - " calcule les différences entre les valeurs consécutives avec un arrondi " + " calcule les diff�rences entre les valeurs cons�cutives avec un arrondi " :non-generic t (let ((l nil) (delta nil)) (dotimes (n (- (length list) 1)) Modified: trunk/src/utils.lisp ============================================================================== --- trunk/src/utils.lisp (original) +++ trunk/src/utils.lisp Sun Jul 15 10:27:06 2007 @@ -31,42 +31,3 @@ (if (consp (car list)) (apply 'append list) list)) -#-(or lispworks digitool) -(defun choose-new-file-dialog (&key (prompt "Enter the path for a new file:") - button-string) - (declare (ignore button-string)) - (format *query-io* "~&~a~%[please enter a path like /tmp/test.txt]~%" prompt) - (force-output *query-io*) - (parse-namestring (read-line *query-io*))) - -#+digitool -(defun choose-new-file-dialog (&key (prompt "Enter the path for a new file:") - button-string) - (ccl::choose-new-file-dialog :prompt prompt :button-string button-string)) - -#+lispworks -(defun choose-new-file-dialog (&key (prompt "Enter the path for a new file:") - button-string) - (capi:prompt-for-file prompt :operation :save)) - -#-(or lispworks digitool) -(defun choose-file-dialog (&key (prompt "Enter the path for an existing file:") - button-string) - (format *query-io* "~&~a~%[please enter a path like /tmp/test.txt]~%" prompt) - (force-output *query-io*) - (let ((path (parse-namestring (read-line *query-io*)))) - (if (probe-file path) - path - (progn - (format *query-io* "~&ERROR: ~A does not exist.~%" path) - (choose-file-dialog :prompt prompt :button-string button-string))))) - -#+digitool -(defun choose-file-dialog (&key (prompt "Enter the path for an existing file:") - button-string) - (ccl::choose-file-dialog :prompt prompt :button-string button-string)) - -#+lispworks -(defun choose-file-dialog (&key (prompt "Enter the path for a new file:") - button-string) - (capi:prompt-for-file prompt))

1 0

[Morphologie-cvs] r22 - trunk/src
by ksprotte＠common-lisp.net 12 Jul '07

12 Jul '07

Author: ksprotte Date: Thu Jul 12 11:37:58 2007 New Revision: 22 Modified: trunk/src/morphologie.lisp Log: this was just a test Modified: trunk/src/morphologie.lisp ============================================================================== --- trunk/src/morphologie.lisp (original) +++ trunk/src/morphologie.lisp Thu Jul 12 11:37:58 2007 @@ -9,6 +9,7 @@ ;;;* Analysis fonctions, pattern recognition and morphological classification of geometric profiles * ;;;* * ;;;************************************************************************************************************* +;;; (in-package :morph)

1 0

[Morphologie-cvs] r21 - trunk/src
by ksprotte＠common-lisp.net 12 Jul '07

12 Jul '07

Author: ksprotte Date: Thu Jul 12 10:45:16 2007 New Revision: 21 Modified: trunk/src/morphologie.lisp Log: converted to utf-8 Modified: trunk/src/morphologie.lisp ============================================================================== --- trunk/src/morphologie.lisp (original) +++ trunk/src/morphologie.lisp Thu Jul 12 10:45:16 2007 @@ -5,7 +5,7 @@ ;;;* IRCAM, Paris, november 1998 for Morphologie 1.0 * ;;;* may 1999 for Morphologie 2.0 * ;;;* * -;;;* Fonctions d'analyse, reconnaissance de pattern et classification morphologiques des profiles g�ometriques * +;;;* Fonctions d'analyse, reconnaissance de pattern et classification morphologiques des profiles géometriques * ;;;* Analysis fonctions, pattern recognition and morphological classification of geometric profiles * ;;;* * ;;;************************************************************************************************************* @@ -141,7 +141,7 @@ (define-box pattern-ridond ((lista nil) &optional (n nil)) "Restituisce tutte le ripetizioni di tutti i sotto-pattern in - cui pu� essere scomposta la sequenza in lista." + cui può essere scomposta la sequenza in lista." :non-generic t (let ((ris nil) (x (scom lista n)) y) (loop :while x @@ -243,8 +243,8 @@ (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. -L'entr�e optionnelle SET specifie les segments recherches dans LIST>" +Renvoie pour chaque fenêtre le nombre d'occurrences d'un élément. +L'entrée optionnelle SET specifie les segments recherches dans LIST>" :non-generic t (count-ptrn-win list windw step set)) @@ -347,8 +347,8 @@ 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> +- PTRN : segment dont les permutations sont recherchés. +tous par défaut. desactive LENGTH> Returns all permutations of two elements in SEQ with their respective positions in seq. @@ -445,7 +445,7 @@ (defparameter **alpha** (quote (#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z - #\�))) + #\°))) (defparameter **num** (quote (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))) @@ -735,24 +735,24 @@ (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)) - "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. + "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; +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 . -result : menu d�roulant, quatre possibilit�s : - short = liste des crit�res de segmentation et leur segmentation respective; - exten = analyse d�taill�e; +result : menu déroulant, quatre possibilités : + short = liste des critères de segmentation et leur segmentation respective; + exten = analyse détaillée; - save = analyse d�taill�e �crite en un fichier texte. + save = analyse détaillée écrite en un fichier texte. OUTPUT en mode short, pour le traitement de l'analyse, liste de liste selon le format : -\((crit�res de segmentation) -\(forme selon crit�re)...)" +\((critères de segmentation) +\(forme selon critère)...)" :non-generic t :menu (alpha? :alpha :num) :menu (smooth? :yes :no) @@ -1110,10 +1110,10 @@ (define-box rma-1 ((seq nil) (smoo1 1) (levels 1) &optional (smoo2 0) (alpha? 1) (result 0)) " -m�me fonction que structure-1, mais r�cursive : -s'applique aussi aux structures trouv�es, avec LEVELS +même fonction que structure-1, mais récursive : +s'applique aussi aux structures trouvées, avec LEVELS comme niveau de recursion. -memes caract�ristiques que structure-1 +memes caractéristiques que structure-1 Recursive Mark Analysis. Returns only found structures." :non-generic t (when (< levels 1) @@ -1873,7 +1873,7 @@ The classe number is arbitrary" (class-1 (l-matrix matrix) n alpha? centers verbose)) -(defun CENTRE-GRAVIT\� (x) +(defun CENTRE-GRAVIT\é (x) (let (sum g (n (nth 1 (array-dimensions x))) @@ -1885,9 +1885,9 @@ (setf (aref g 0 i) (float (/ sum m)))))) (define-box matrix-center ((matrix nil)) - "Donne les coordonn�es du centre de gravit� d'une matrice - des coordonn�es de points en n-dimensions (utiliser l-matrix -pour convertir une liste de coordonn�es de points en matrice). + "Donne les coordonnées du centre de gravité d'une matrice + des coordonnées de points en n-dimensions (utiliser l-matrix +pour convertir une liste de coordonnées de points en matrice). " :non-generic t (let (sum @@ -1901,18 +1901,18 @@ (setf (aref g 0 i) (float (/ sum m)))))) -(defun X-CENTR\�E (x) - (let ((g (CENTRE-GRAVIT\� x)) +(defun X-CENTR\éE (x) + (let ((g (CENTRE-GRAVIT\é x)) (n (nth 1 (array-dimensions x))) (m (nth 0 (array-dimensions x))) - CENTR\�E) - (setq CENTR\�E (make-array (list m n))) - (dotimes (i m CENTR\�E) - (dotimes (j n) (setf (aref CENTR\�E i j) (aref g 0 j)))) - (setf CENTR\�E (subtract-two-matrices x CENTR\�E)))) + CENTR\éE) + (setq CENTR\éE (make-array (list m n))) + (dotimes (i m CENTR\éE) + (dotimes (j n) (setf (aref CENTR\éE i j) (aref g 0 j)))) + (setf CENTR\éE (subtract-two-matrices x CENTR\éE)))) (defun dist-grav (x) - (let ((grav (CENTRE-GRAVIT\� x)) + (let ((grav (CENTRE-GRAVIT\é x)) d-grav diff (m (nth 0 (array-dimensions x))) @@ -1988,7 +1988,7 @@ collect (aref mat-dist i j))))) (defun rand-classes (m n) - "cr�e une m-liste al�atoire de n nombres diff�rents" + "crée une m-liste aléatoire de n nombres différents" (let ((alea nil) (alea-test nil)) (dotimes (a m alea) (push (random n) alea)) (setf alea-test (remove-duplicates alea)) @@ -1996,7 +1996,7 @@ (defun centre-classes (x classes *m* *n* *n-cl*) "input = matrice des points - liste-vecteur des classes attribu�es � chaque point + liste-vecteur des classes attribuées à chaque point output = matrice des centres de chaque classe" (let (nuage point c tc centres) (setf centres (make-array (list *n-cl* *n*))) @@ -2011,7 +2011,7 @@ (cond ((eq (nth a classes) b) (setf point (+ point 1)) (dotimes (d *n*) (setf (aref nuage (- point 1) d) (aref x a d))) - (setf tc (CENTRE-GRAVIT\� nuage))))) + (setf tc (CENTRE-GRAVIT\é nuage))))) (dotimes (d *n*) (setf (aref centres b d) (aref tc 0 d)))))) (define-box class-center ((matrix nil) (classes nil)) @@ -2041,7 +2041,7 @@ (setf point (+ point 1)) (dotimes (d *n*) (setf (aref nuage (- point 1) d) (aref matrix a d))) - (setf tc (CENTRE-GRAVIT\� nuage))))) + (setf tc (CENTRE-GRAVIT\é nuage))))) (dotimes (d *n*) (setf (aref centres b d) (aref tc 0 d)))))) @@ -2065,7 +2065,7 @@ data : list of classes distribution (typically data from class-1; OUT Shannon entropie value, 0 <= entropie <= (log n 2). -Cf. J. Wasemberg : L �me de la m�duse, id�es sur la complexit� du monde, +Cf. J. Wasemberg : L âme de la méduse, idées sur la complexité du monde, Seuil, Paris, 1997." (let ((cl (remove-duplicates data)) (n (length data)) (p nil)) (dolist (ci cl (- 0 (apply #'+ (mapcar #'(lambda (x) (* x (log x 2))) p)))) @@ -2080,7 +2080,7 @@ Shannon entropie value 0 <= entropy <= (log n 2) if res = absolute; 0 <= entropy <= 1.0 if res = relative. -Cf. J. Wasemberg : L �me de la m�duse, id�es sur la complexit� du monde, +Cf. J. Wasemberg : L âme de la méduse, idées sur la complexité du monde, Seuil, Paris, 1997." :menu (res (:abs "absolute") (:rel "relative")) (declare (ignore class res)) @@ -2094,7 +2094,7 @@ Shannon entropie value 0 <= entropy <= (log n 2) if res = absolute; 0 <= entropy <= 1.0 if res = relative. -Cf. J. Wasemberg : L �me de la m�duse, id�es sur la complexit� du monde, +Cf. J. Wasemberg : L âme de la méduse, idées sur la complexité du monde, Seuil, Paris, 1997." (cond ((not (member 'nil (mapcar #'atom class))) (if (equalp res :abs) (setf res 1) (setf res 0)) @@ -2116,7 +2116,7 @@ Shannon entropie value 0 <= entropy <= (log n 2) if res = absolute; 0 <= entropy <= 1.0 if res = relative. -Cf. J. Wasemberg : L �me de la m�duse, id�es sur la complexit� du monde, +Cf. J. Wasemberg : L âme de la méduse, idées sur la complexité du monde, Seuil, Paris, 1997." (setf class (str->symb class)) (entropy class res)) @@ -2147,8 +2147,8 @@ (defun normalize-class (classes) "reordonne les classes de class-1. -L'ordre de la classe �tant le num�ro de sa premi�re occurence dans la liste des classes. -Se connecte typiquement apr�s class-1 ou meta-class1." +L'ordre de la classe étant le numéro de sa première occurence dans la liste des classes. +Se connecte typiquement après class-1 ou meta-class1." (let ((set nil) (r nil) (marker -1) (tempset nil) n) (when (stringp classes) (setf classes (str->symb classes))) (setf n (length (remove-duplicates classes))) @@ -2163,8 +2163,8 @@ (define-box norm-class ((classes nil)) "reordonne les classes de class-1. -L'ordre de la classe �tant le num�ro de sa premi�re occurence dans la liste des classes. -Se connecte typiquement apr�s class-1 ou meta-class1. +L'ordre de la classe étant le numéro de sa première occurence dans la liste des classes. +Se connecte typiquement après class-1 ou meta-class1. IN : string or list (of symbols or lists or strings)." :non-generic t (if (or (stringp classes) (not (listp (car classes)))) @@ -2452,23 +2452,23 @@ 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 +minima: element précédé et suivi par un élément de valeur plus grande. -maxima: element pr�c�d� et suivi par un �l�ment +maxima: element précédé et suivi par un élément de valeur plus petite -flex: element pr�c�d� et suivi par un �l�ment -de valeur �gale +flex: element précédé et suivi par un élément +de valeur égale ex : (10 8 8 6 6 5 2 2 2 1) 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 +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 les informations: prim: succession des primitives -prof: succession des primitives et profondeur en nombre d'�l�ments de +prof: succession des primitives et profondeur en nombre d'éléments de chaque primitive -vals: idem que prof + valeur correspondant � chaque primitive +vals: idem que prof + valeur correspondant à chaque primitive every: idem que vals + position de chaque primitive" :non-generic t :menu (result (1 "prim") (2 "prof") (3 "vals") (4 "every")) @@ -2494,7 +2494,7 @@ (define-box 1-0-1-reconst ((list nil)) "fonction dx->x d'OM : renvoie une liste de points depuis une liste - d'intervalles . commence � zero" + d'intervalles . commence à zero" :non-generic t (OM::dx->x 0 list)) @@ -2557,7 +2557,7 @@ (define-box reconst-prim+prof ((list nil)) "Ricostruisce la lista usando min, max, flex - pi� eventualmente l'indice di profondit�" + più eventualmente l'indice di profondità" :non-generic t (let ((ris nil) (start 0)) (dolist (y list @@ -2579,8 +2579,8 @@ ris)))) -(defun rec-st-2 (struct |N�| &optional seq) - (let* ((rs (nth |N�| struct)) +(defun rec-st-2 (struct |N°| &optional seq) + (let* ((rs (nth |N°| struct)) (risultato (mapcar #'(lambda (x) (OM::flat (nth x (cadr rs)))) (mapcar #'1- (cadar rs))))) @@ -2589,27 +2589,27 @@ (OM::flat risultato)))) (define-box struct2-to-seq ((struct nil) (n nil) &optional ptrns) - "Reconstruit une s�quence correspondant � la structure donn�e en struct. - Optional : reconstruit une s�quence de m�me structure avec les patterns - donn�s en ptrns." + "Reconstruit une séquence correspondant à la structure donnée en struct. + Optional : reconstruit une séquence de même structure avec les patterns + donnés en ptrns." (declare (ignore struct n)) (error "default method. should not be called.")) (defmethod struct2-to-seq ((struct list) (n integer) &optional ptrns) - "Reconstruit une s�quence correspondant � la structure donn�e en struct. - Optional : reconstruit une s�quence de m�me structure avec les patterns - donn�s en ptrns." + "Reconstruit une séquence correspondant à la structure donnée en struct. + Optional : reconstruit une séquence de même structure avec les patterns + donnés en ptrns." (rec-st-2 struct n ptrns)) (defmethod struct2-to-seq ((struct list) (n list) &optional ptrns) - "Reconstruit une s�quence correspondant � la structure donn�e en struct. - Optional : reconstruit une s�quence de m�me structure avec les patterns - donn�s en ptrns." + "Reconstruit une séquence correspondant à la structure donnée en struct. + Optional : reconstruit une séquence de même structure avec les patterns + donnés en ptrns." (mapcar #'(lambda (i) (rec-st-2 struct i ptrns)) n)) (define-box reconst-prim+prof+val ((list nil) (start 6000)) "Ricostruisce la lista usando min, max, flex - pi� eventualmente l'indice di profondit�" + più eventualmente l'indice di profondità" :non-generic t (let ((ris nil)) (dotimes (x (length list) (OM::flat (nreverse ris))) @@ -2639,7 +2639,7 @@ (define-box pos+prim+prof+val ((list nil) (start 6000)) "Ricostruisce la lista usando min, max, flex - pi� eventualmente l'indice di profondit�" + più eventualmente l'indice di profondità" :non-generic t (let ((ris nil) (valore nil)) (dotimes (x (length list) @@ -2721,7 +2721,7 @@ (define-box controlla-ottave ((list1 nil) (list2 nil) (modul 12)) "studia i casi particolari della melodia in questione se questa - � trasposta pi� o meno esattamente" + è trasposta più o meno esattamente" :non-generic t (let* ((ris nil) (ros nil) @@ -2992,9 +2992,9 @@ (define-box multi-distance ((seq1 nil) (seq2 nil) (change 1) (ins/sup 1) (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." + "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." :non-generic t (if inex (dist-2-ldl seq1 seq2 change ins/sup inex wgth) @@ -3023,8 +3023,8 @@ (define-box resemblance ((a nil) (b nil) (wocc 1.0) (wref 1.0) &optional (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. + "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; Wref : poids de la structure de repetition." :menu (diff :res :diss) @@ -3033,8 +3033,8 @@ (defmethod resemblance ((a list) (b list) (wocc float) (wref float) &optional diff) - "Calcule une valeur de ressemblance entre 0 et 100 entre deux s�quences -de symboles selon le crit�re de leur structure interne. + "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; Wref : poids de la structure de repetition." (let* ((ma (resemblance-match a a)) @@ -3075,13 +3075,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))) @@ -3102,13 +3102,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)) @@ -3139,7 +3139,7 @@ (define-box octave ((midic 6000)) - "retourne l'octave � partir de c3=octave 3" + "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)) @@ -3147,14 +3147,14 @@ (define-box makenote ((index 60) (octave 3) &optional (mod 12)) - " construction d'une note � partir des donn�es + " construction d'une note à partir des données de index, octave e modulo du index" :non-generic t (+ (/ (* index 100 12) mod) (* (+ 2 octave) 1200))) (defun lettura-modulare (lista1 lista2) - "Se la prima lista � pi� grande della seconda lista, allora legge + "Se la prima lista è più grande della seconda lista, allora legge modularmente la seconda lista restituendo un length uguale al length di lista1." (let ((ros nil)) @@ -3183,10 +3183,10 @@ (define-box prof-inter ((list1 nil) (list2 nil) (total 1)) - "Restituisce l'interposizione di list1 con list2. Se list1 � pi� piccola + "Restituisce l'interposizione di list1 con list2. Se list1 è più piccola di list2 allora la funzione crea un'interposizione di n elementi di list2 dove (= n (- (length list1) 1)). In questo caso si puo' decidere con il - men� se avere la prima ricorsione per completare list2." + menù se avere la prima ricorsione per completare list2." :non-generic t :menu (total (1 "ltd") (2 "copl")) (case total @@ -3197,14 +3197,14 @@ (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) + (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)))) + (permut-circ list2 (1- (length list1))) (- GR\° 1)))) (define-box new-inter-profile ((list1 nil) (list2 nil)) @@ -3228,14 +3228,14 @@ (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) + (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)))) + (permut-circ list2 (1- (length list1))) (- GR\° 1)))) (defun int-com-ottava (lista) @@ -3278,9 +3278,9 @@ (define-box correttore ((elmt 1) (range nil)) "Restituisce un elemento se questo compare all'interno del range. - Se l'elemento � escluso allora lo traspone in modo tale che sia - il pi� vicino possibile o al limite superiore o a quello inferiore. - Se il limite � DO-SOL allora Mi viene incluso, SI viene trasposto + Se l'elemento è escluso allora lo traspone in modo tale che sia + il più vicino possibile o al limite superiore o a quello inferiore. + Se il limite è DO-SOL allora Mi viene incluso, SI viene trasposto sotto il DO e il SOL# viene trasposto sopra il SOL." :non-generic t (let ((max (g-max range)) (min (g-min range))) @@ -3296,26 +3296,26 @@ (defun cor-ott-list (elmt range) "Restituisce un elemento se questo compare all'interno del range. - Se l'elemento � escluso allora lo traspone in modo tale che sia - il pi� vicino possibile o al limite superiore o a quello inferiore. - Se il limite � DO-SOL allora Mi viene incluso, SI viene trasposto + Se l'elemento è escluso allora lo traspone in modo tale che sia + il più vicino possibile o al limite superiore o a quello inferiore. + Se il limite è DO-SOL allora Mi viene incluso, SI viene trasposto sotto il DO e il SOL# viene trasposto sopra il SOL.La differenza - con 'CORRETTORE' � che questo modulo agisce su una lista intera." + con 'CORRETTORE' è che questo modulo agisce su una lista intera." (let ((ris nil)) (dolist (y elmt) (push (correttore y range) ris)) (nreverse ris))) (define-box trans-approx ((list nil) (range nil)) "E' meglio di transpoct di Esquisse. Infatti attua lo stesso - procedimento ma traspone una nota non inclusa nel range il pi� + procedimento ma traspone una nota non inclusa nel range il più vicino o al limite superiore o a quello inferiore." :non-generic t (cor-ott-list (mio-transpoct list range) range)) (define-box direct-analysis ((list (6000 4000 6900 7300 6100 5900))) - "donne le signe de la d�riv�e locale (-1. 0 +1) pour chaque point de la liste -des valeurs donn�es en entr�e." + "donne le signe de la dérivée locale (-1. 0 +1) pour chaque point de la liste +des valeurs données en entrée." :non-generic t (let ((ris nil)) (dotimes (x (length (OM::x->dx list)) (nreverse ris)) @@ -3363,8 +3363,8 @@ (defun interno (elmt range) - "Restituisce l'elemento se � incluso nel 'range' e nil - se non � incluso." + "Restituisce l'elemento se è incluso nel 'range' e nil + se non è incluso." (if (<= (g-min range) elmt (g-max range)) elmt nil)) (define-box malt-mod- ((list nil) (limit 6000)) @@ -3377,7 +3377,7 @@ (define-box reflex-int ((ls nil) (value 0) (up/down 1)) "Restituisce la rifleesione delle note che sono superiori o inferiori - al valore indicato con 'value'. Il men� permette di selezionare se si + al valore indicato con 'value'. Il menù permette di selezionare se si vuole una riflessione superiore o inferiore" :non-generic t :menu (up/down (1 "up") (2 "down")) @@ -3498,7 +3498,7 @@ (define-box comp-octave ((list nil) (range nil)) "Restituisce una trasposizione della lista mantenendo le altezze - assolute all'interno del 'range. Se un elemento non � incluso + assolute all'interno del 'range. Se un elemento non è incluso nel 'range', allora viene tolto dal risultato." :non-generic t (let ((ris nil)) @@ -3508,8 +3508,8 @@ (define-box 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 + 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")) @@ -3521,9 +3521,9 @@ (define-box rtm-change-1 ((rhytm nil) (vals nil)) - "Se in vals c'� un solo valore allora calcola una + "Se in vals c'è un solo valore allora calcola una approssimazione ritmica in modo tale che tutti i valori - risultino un multiplo di vals. Se invece in vals c'� una + risultino un multiplo di vals. Se invece in vals c'è una lista di valori allora approssima tutti i valori in rtm con i valori di vals." :non-generic t @@ -3553,8 +3553,8 @@ (define-box rtm-change-1val ((rht nil) (val 1)) "Questa funzione prende ogni elemento di rht e restituisce - lo stesso elemento se il (mod rht val) � uguale a 0 - altrimenti lo approssima al po� vicino" + lo stesso elemento se il (mod rht val) è uguale a 0 + altrimenti lo approssima al poù vicino" :non-generic t (let ((ris nil)) (dolist (y rht (nreverse ris)) @@ -3575,13 +3575,13 @@ (define-box segno+picc ((list nil)) "Trasforma tutta la lista in valori tutti positivi e prende il valore - pi� piccolo." + più piccolo." :non-generic t (g-min (mapcar #'(lambda (x) (abs x)) list))) (define-box nota-vicina ((list nil) (ref 1)) - "Prende l'intervallo pi� piccolo di una lista." + "Prende l'intervallo più piccolo di una lista." :non-generic t (let* ((intervalli (tutti-int list ref)) (piccolo (segno+picc intervalli))) (if (equalp (abs (first intervalli)) piccolo) @@ -3590,13 +3590,13 @@ (define-box tieni-nota ((list nil) (ref 1)) - "tiene la nota pi� vicina." + "tiene la nota più vicina." :non-generic t (OM::om+ ref (nota-vicina list ref))) (define-box vicini-valori ((list1 nil) (refs nil)) - "Prende le note pi� vicine di list per ogni nota di refs." + "Prende le note più vicine di list per ogni nota di refs." :non-generic t (mapcar #'(lambda (x) (tieni-nota list1 x)) refs)) @@ -3797,8 +3797,8 @@ (define-box prim-tree ((dist nil)) "Builds up the shorter tree of the points given in the matrix of distances (list of list), distances must be expressed as ((xi yi di) etc.). -prend en entr�e la sortie de ldl-distance en mode extend. -See: E. Diday & all, 1982 : Elements d'analyse de donn�es, Dunod, Paris. pp. 110-111." +prend en entrée la sortie de ldl-distance en mode extend. +See: E. Diday & all, 1982 : Elements d'analyse de données, Dunod, Paris. pp. 110-111." :non-generic t (assert (not (member 0 dist :test #'equalp :key #'third)) nil @@ -3905,7 +3905,7 @@ (define-box delta ((list nil) (round 1000)) - " calcule les diff�rences entre les valeurs cons�cutives avec un arrondi " + " calcule les différences entre les valeurs consécutives avec un arrondi " :non-generic t (let ((l nil) (delta nil)) (dotimes (n (- (length list) 1))

1 0

[Morphologie-cvs] r20 - trunk/src
by ksprotte＠common-lisp.net 11 Jul '07

11 Jul '07

Author: ksprotte Date: Wed Jul 11 12:37:43 2007 New Revision: 20 Modified: trunk/src/morphologie.lisp Log: define-menu Modified: trunk/src/morphologie.lisp ============================================================================== --- trunk/src/morphologie.lisp (original) +++ trunk/src/morphologie.lisp Wed Jul 11 12:37:43 2007 @@ -33,7 +33,7 @@ ;; :do (push (remove nil (nreverse (svref vector i))) res)) ;; (nreverse res))) -(def-menu morphologie) +(define-menu morphologie) (in-menu morphologie) ;;; until all OM symbols are out

1 0

[Morphologie-cvs] r19 - trunk
by ksprotte＠common-lisp.net 06 Jul '07

06 Jul '07

Author: ksprotte Date: Fri Jul 6 09:38:59 2007 New Revision: 19 Added: trunk/load.lisp Log: added load.lisp for OM Added: trunk/load.lisp ============================================================================== --- (empty file) +++ trunk/load.lisp Fri Jul 6 09:38:59 2007 @@ -0,0 +1,2 @@ +(asdf:oos 'asdf:load-op :morphologie) +

1 0

[Morphologie-cvs] r18 - trunk/src
by ksprotte＠common-lisp.net 06 Jul '07

06 Jul '07

Author: ksprotte Date: Fri Jul 6 09:34:52 2007 New Revision: 18 Modified: trunk/src/morphologie.lisp Log: replaced most of the :menu strings to keywords Modified: trunk/src/morphologie.lisp ============================================================================== --- trunk/src/morphologie.lisp (original) +++ trunk/src/morphologie.lisp Fri Jul 6 09:34:52 2007 @@ -340,7 +340,7 @@ (setf (nth p r) (append (nth p r) (list i))) (push (list seqa i) r)))))))) -(define-box find-permut ((seq nil) (output "permut") &optional (length nil) +(define-box 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 @@ -358,13 +358,13 @@ PTRN : pattern of which permutations are looking for. If not empty (nil), desactivates LENGTH>" :non-generic t - :menu (output ("pos" "positions") ("permut" "permutations")) + :menu (output (:pos "positions") (:permut "permutations")) (assert (listp ptrn)) (if (and (and length (listp length)) (null ptrn)) (mapcar #'(lambda (x) (find-permut seq output x 'nil)) length) (let ((r (if ptrn (permuts seq ptrn) (local-permut seq length)))) - (cond ((equalp "pos" output) r) - ((equalp "permut" output) + (cond ((equalp :pos output) r) + ((equalp :permut output) (if ptrn (mapcar #'car r) (mapcar #'(lambda (x) (mapcar #'car x)) r))))))) @@ -372,8 +372,8 @@ (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; @@ -385,16 +385,16 @@ OUTPUT A matrix of distances" :non-generic t - :menu (scale ("rel" "relative") ("abs" "absolute")) - :menu (result ("short" "short") ("ext" "extended") ("save" "save")) + :menu (scale :rel :abs) + :menu (result :short :ext :save) (when (not (= (length l-seq) (length (remove-duplicates (copy-tree l-seq) :test #'equal)))) (format t "ldl-distance warning: duplicates in input list.~%")) (let ((r nil)) - (if (equalp scale "rel") (setf scale 1) (setf scale 2)) - (cond ((equalp result "short") (setf result 1)) - ((equalp result "ext") (setf result 2)) - ((equalp result "save") (setf result 2)) + (if (equalp scale :rel) (setf scale 1) (setf scale 2)) + (cond ((equalp result :short) (setf result 1)) + ((equalp result :ext) (setf result 2)) + ((equalp result :save) (setf result 2)) (t (print "Error result menu doesn't exist.") (abort))) (cond ((= inex 0.0) (dotimes (l1 (length l-seq) @@ -1780,13 +1780,13 @@ (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. The classe number is arbitrary" :menu (alpha? (1 "alpha") (0 "num")) - :menu (verbose ("no" "no") ("yes" "yes")) + :menu (verbose :no :yes) (declare (ignore matrix n)) (error "default method. should not be called.")) @@ -2072,7 +2072,7 @@ (push (/ (length (remove-if-not #'(lambda (x) (equal x ci)) data)) n) p)))) -(define-box entropy ((class nil) (res "abs")) +(define-box entropy ((class nil) (res :abs)) "Returns the Shannon entropy value of the data classified. data : list of classes distribution (typically data from class-1); res : absolute or relative entropy; @@ -2082,7 +2082,7 @@ 0 <= entropy <= 1.0 if res = relative. Cf. J. Wasemberg : L �me de la m�duse, id�es sur la complexit� du monde, Seuil, Paris, 1997." - :menu (res ("abs" "absolute") ("rel" "relative")) + :menu (res (:abs "absolute") (:rel "relative")) (declare (ignore class res)) (error "default method. should not be called.")) @@ -2097,7 +2097,7 @@ Cf. J. Wasemberg : L �me de la m�duse, id�es sur la complexit� du monde, Seuil, Paris, 1997." (cond ((not (member 'nil (mapcar #'atom class))) - (if (equalp res "abs") (setf res 1) (setf res 0)) + (if (equalp res :abs) (setf res 1) (setf res 0)) (cond ((= res 1) (eshannon class)) ((= res 0) (let ((cl (remove-duplicates class))) @@ -2126,19 +2126,19 @@ "Does n iterations of class-1 algorithm. The classes designation is normalized." :non-generic t - :menu (alpha? ("alpha" "alpha") ("num" "num")) - :menu (verbose ("no" "no") ("yes" "yes")) + :menu (alpha? :alpha :num) + :menu (verbose :no :yes) (when (and (listp matrix) (not (arrayp matrix))) (setf matrix (l-matrix matrix))) - (if (equalp "no" verbose) (setf verbose "no") (setf verbose "yes")) + (if (equalp :no verbose) (setf verbose :no) (setf verbose :yes)) (let ((r nil) res-r) (dotimes (a iter (setf r (prob-class (reverse r)))) (let ((classa (class-1 matrix n 0 centers verbose))) - (when (equal verbose "yes") + (when (equal verbose :yes) (format t "~% Meta-class1 - iteration #~S -~%" (1+ a))) (push classa r))) (setf res-r (res-class r 0)) - (if (equalp "num" alpha?) + (if (equalp :num alpha?) (values res-r (mat-to-ldl (class-center matrix res-r)) (mat-to-ldl r)) (values (to-alpha (mapcar #'1+ res-r)) (mat-to-ldl (class-center matrix res-r)) @@ -2229,13 +2229,13 @@ (pos2 e entropies) (mapcar #'(lambda (n) (nth n clusters)) (pos2 e entropies))))) -(define-box e-test ((clusters nil) (test "min") &optional (out "clust")) +(define-box e-test ((clusters nil) (test :min) &optional (out :clust)) "Returns the clusters which have the minimum or maximum entropy." :non-generic t - :menu (test ("min" "min") ("max" "max")) - :menu (out ("clust" "clust") ("nth" "nth")) - (if (equalp "min" test) (setf test 0) (setf test 1)) - (if (equalp "clust" out) + :menu (test :min :max) + :menu (out :clust :nth) + (if (equalp :min test) (setf test 0) (setf test 1)) + (if (equalp :clust out) (car (remove-duplicates (test-entropie clusters test 1) :test #'equalp)) (test-entropie clusters test 0))) @@ -3022,12 +3022,12 @@ (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; Wref : poids de la structure de repetition." - :menu (diff ("res" "res") ("diss" "diss")) + :menu (diff :res :diss) (declare (ignore a b wocc wref)) (error "default method. should not be called.")) @@ -3043,7 +3043,7 @@ (occ-b (mapcar #'(lambda (x) (apply #'+ x)) mb)) (ref-a (ref-position a)) (ref-b (ref-position b))) - (if (equalp "diss" diff) + (if (equalp :diss diff) (multi-distance (mapcar #'(lambda (x y) (list x y)) occ-a ref-a) (mapcar #'(lambda (x y) (list x y)) occ-b ref-b) 1 1 (list wocc wref)) (- 100.0

1 0

[Morphologie-cvs] r17 - trunk/src
by ksprotte＠common-lisp.net 06 Jul '07

06 Jul '07

Author: ksprotte Date: Fri Jul 6 09:25:35 2007 New Revision: 17 Modified: trunk/src/morphologie.lisp Log: some menu correctionsome menu correctionss Modified: trunk/src/morphologie.lisp ============================================================================== --- trunk/src/morphologie.lisp (original) +++ trunk/src/morphologie.lisp Fri Jul 6 09:25:35 2007 @@ -1447,7 +1447,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 0)) + &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. @@ -3188,7 +3188,7 @@ dove (= n (- (length list1) 1)). In questo caso si puo' decidere con il men� se avere la prima ricorsione per completare list2." :non-generic t - :menu (list2 (1 "ltd") (2 "copl")) + :menu (total (1 "ltd") (2 "copl")) (case total (1 (inter-profile list1 list2)) (2 @@ -3919,7 +3919,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 : @@ -3932,7 +3932,7 @@ :menu (fontname ("geneva" "Geneva") ("helvetica" "Helvetica") ("monaco" "Monaco") ("new york" "New York") ("times" "Times")) :menu (fontsize (9 "9") (10 "10") (12 "12") (14 "14") (18 "18")) - :menu (fontstyle (nil "normal") (:bold "bold")) + :menu (fontstyle (:normal "normal") (:bold "bold")) (let* ((window-name (if name (cond ((stringp name) name) ((symbolp name) (string name)))

1 0

[Morphologie-cvs] r16 - in trunk: . src
by ksprotte＠common-lisp.net 06 Jul '07

06 Jul '07

Author: ksprotte Date: Fri Jul 6 05:15:45 2007 New Revision: 16 Added: trunk/TODO Modified: trunk/morphologie.asd trunk/src/morphologie.lisp Log: small ch Added: trunk/TODO ============================================================================== --- (empty file) +++ trunk/TODO Fri Jul 6 05:15:45 2007 @@ -0,0 +1 @@ +* printed output in PWGL is not showing up - what to do? \ No newline at end of file Modified: trunk/morphologie.asd ============================================================================== --- trunk/morphologie.asd (original) +++ trunk/morphologie.asd Fri Jul 6 05:15:45 2007 @@ -1,8 +1,10 @@ (in-package :asdf) (defsystem :morphologie + :version "3.0" :components - ((:module :src + ((:static-file "morphologie.asd") + (:module :src :serial t :components ((:file "package") Modified: trunk/src/morphologie.lisp ============================================================================== --- trunk/src/morphologie.lisp (original) +++ trunk/src/morphologie.lisp Fri Jul 6 05:15:45 2007 @@ -36,6 +36,11 @@ (def-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

1 0

[Morphologie-cvs] r15 - trunk/src
by ksprotte＠common-lisp.net 06 Jul '07

06 Jul '07

Author: ksprotte Date: Fri Jul 6 04:24:17 2007 New Revision: 15 Modified: trunk/src/morphologie.lisp Log: define-ompw -> define-box Modified: trunk/src/morphologie.lisp ============================================================================== --- trunk/src/morphologie.lisp (original) +++ trunk/src/morphologie.lisp Fri Jul 6 04:24:17 2007 @@ -20,7 +20,7 @@ ;; with this code. ;; see my reimplementation below -;; (define-ompw list-modulo (list &optional ncol) +;; (define-box list-modulo (list &optional ncol) ;; "partitions LIST in NCOL lists containing the elements modulo NCOL" ;; :non-generic t ;; (let ((vector (make-array ncol)) res) @@ -36,7 +36,7 @@ (def-menu morphologie) (in-menu morphologie) -(define-ompw list-modulo (list &optional ncol) +(define-box list-modulo (list &optional ncol) "partitions LIST in NCOL lists containing the elements modulo NCOL" :non-generic t ;; new implementation by Kilian @@ -73,33 +73,33 @@ (defun the-max (x) (apply 'max x)) -(define-ompw g-min (list) +(define-box g-min (list) :non-generic t :export nil ; just for trying things out, we exclude this from the menu (less-deep-mapcar #'the-min (list! list))) -(define-ompw g-max (list) +(define-box g-max (list) :non-generic t (less-deep-mapcar #'the-max (list! list))) -(define-ompw l-nth (list l-nth) +(define-box l-nth (list l-nth) :non-generic t (deep-mapcar 'l-nth 'nth l-nth list)) -(define-ompw posn-match (list l-nth) +(define-box posn-match (list l-nth) :non-generic t (deep-mapcar 'l-nth 'nth l-nth (list! list))) -(define-ompw permut-circ (list &optional nth) +(define-box permut-circ (list &optional nth) :non-generic t (permut-circn (copy-list list) nth)) -(define-ompw permut-circn (list &optional nth) +(define-box permut-circn (list &optional nth) :non-generic t (when list (let ((length (length list)) n-1thcdr) @@ -109,14 +109,13 @@ (prog1 (cdr (nconc (setq n-1thcdr (nthcdr (1- nth) list)) list)) (rplacd n-1thcdr nil)))))) - -(define-ompw primo-passo ((lista nil) (n 1)) +(define-box primo-passo ((lista nil) (n 1)) "prende n elementi di una lista" :non-generic t (let ((f nil)) (dotimes (x n) (push (nth x lista) f)) (nreverse f))) -(define-ompw scom ((lista1 nil) &optional (n nil)) +(define-box scom ((lista1 nil) &optional (n nil)) "Scompone la lista1 in funzione delle lunghezze indicate nella n" :non-generic t (let ((ris nil)) @@ -135,7 +134,7 @@ (reverse ris))) -(define-ompw pattern-ridond ((lista nil) &optional (n nil)) +(define-box pattern-ridond ((lista nil) &optional (n nil)) "Restituisce tutte le ripetizioni di tutti i sotto-pattern in cui pu� essere scomposta la sequenza in lista." :non-generic t @@ -145,7 +144,7 @@ (reverse ris))) -(define-ompw ptrn-recogn ((list (1 2 3 1 2 3 1 2 1 2))) +(define-box ptrn-recogn ((list (1 2 3 1 2 3 1 2 1 2))) "restituisce..." :non-generic t (let* ((ris nil) @@ -159,14 +158,14 @@ (push (append (list (nth x calcoletto)) (list (nth x calcolaccio))) ris)))) -(define-ompw rispero ((lista (1 2)) (n 0)) +(define-box rispero ((lista (1 2)) (n 0)) "E' come spero solo che divide la lista in base al valore messo in n" :non-generic t (scom lista n)) -(define-ompw risperiamo ((lista nil) (n 0)) +(define-box risperiamo ((lista nil) (n 0)) "E' molto simile a speriamo : trova i pattern di n lunghezza all'interno della lista" :non-generic t @@ -175,7 +174,7 @@ (if (equalp (subsetp (list nil) x :test #'equal) nil) (push x ris))))) -(define-ompw ptrn-ridond-ctrl-prov ((lista nil) (n nil)) +(define-box ptrn-ridond-ctrl-prov ((lista nil) (n nil)) "Restituisce tutti i sotto-pattern che compaiono almeno due volte (ridondanza) e le cui length sono decise da noi in N." @@ -186,7 +185,7 @@ (nreverse ris))) -(define-ompw ptrn-find ((list (1 2 3 1 2 3 1 2 1 2)) (n nil)) +(define-box 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 avec leur nombre d'occurences. Est considere comme pattern tout segment de LIST @@ -235,7 +234,7 @@ (let ((max (apply #'max (mapcar #'cadr list)))) (remove-if #'(lambda (x) (< (cadr x) max)) list))) -(define-ompw ptrn-reson ((list (a b c a b c b b b b a a)) (windw 5) &optional +(define-box 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 . @@ -282,7 +281,7 @@ (sort-list-char a #'car)) result-not-sorted))))))) -(define-ompw ptrn-smooth ((list (a b c d b b))) +(define-box ptrn-smooth ((list (a b c d b b))) "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))" @@ -336,7 +335,7 @@ (setf (nth p r) (append (nth p r) (list i))) (push (list seqa i) r)))))))) -(define-ompw find-permut ((seq nil) (output "permut") &optional (length nil) +(define-box 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 @@ -367,7 +366,7 @@ (menu-separator) -(define-ompw ldl-distance ((l-seq ((a b c) (a b b) (a b c))) (change 1.0) +(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")) "Estimates the distances between lists of symbols. @@ -526,7 +525,7 @@ r))))) (when (stringp string) (readst string)))) -(define-ompw str->symb ((strings nil)) +(define-box str->symb ((strings nil)) "Converts string or list of strings or list of list of strings into list (list of list) of symbols. !! : please replace double quotes by simple quotes before evalution." (declare (ignore strings)) @@ -542,7 +541,7 @@ !! : please replace double quotes by simple quotes before evalution." (string-to-symbol strings)) -(define-ompw num->alpha ((list nil)) +(define-box num->alpha ((list nil)) "converts list of lists and/or integers to symbols : 0 -> a 1 -> b @@ -567,7 +566,7 @@ etc." (numtochar0 list)) -(define-ompw minirec (list) +(define-box minirec (list) (declare (ignore list)) (error "default method. should not be called.")) @@ -575,7 +574,7 @@ (defmethod minirec ((list list)) (apply #'min (fflat list))) -(define-ompw midicents-to-name (x &optional approx) +(define-box midicents-to-name (x &optional approx) "Converts a midic number to a CMN name approx values are .5 .25 .125 " :non-generic t @@ -618,12 +617,12 @@ (defun mc->alpha1 (midicents approx) (mc-to-name midicents approx)) -(define-ompw mc->alpha ((midicents nil) approx) +(define-box mc->alpha ((midicents nil) approx) :non-generic t (mc->alpha midicents approx)) -(define-ompw concatstrings ((lofstrings nil)) +(define-box concatstrings ((lofstrings nil)) "Concantenates list of strings into one string." :non-generic t (let ((concatenated @@ -641,7 +640,7 @@ "Converts midicents values into symboles." (string-to-symbol (mc-to-name midiseq approx))) -(define-ompw midiseq->alpha ((midiseq nil) (approx 0)) +(define-box midiseq->alpha ((midiseq nil) (approx 0)) "Converts midicents values into symboles." :non-generic t (midiseq->alpha1 midiseq approx)) @@ -729,7 +728,7 @@ (format stream "~S " (nth n (cadr from-struct-1))) (format stream "~%~%")))) -(define-ompw structure-1 ((seq (a b c a b c d a c c d a a b c a)) &optional (alpha? :alpha) (smooth? :yes) +(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)) "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. @@ -873,7 +872,7 @@ (defun modulo26 (num) (values (mod num 26) (floor (/ num 26)))) -(define-ompw numtochar (num) +(define-box numtochar (num) (declare (ignore num)) (error "default method. should not be called.")) @@ -889,7 +888,7 @@ (defmethod numtochar ((num list)) (mapcar #'numtochar num)) -(define-ompw numtochar0 (num) +(define-box numtochar0 (num) (declare (ignore num)) (error "default method. should not be called.")) @@ -905,7 +904,7 @@ (defmethod numtochar0 ((num list)) (mapcar #'numtochar0 num)) -(define-ompw numtochar2 (num) +(define-box numtochar2 (num) (declare (ignore num)) (error "default method. should not be called.")) @@ -924,7 +923,7 @@ (setf (elt main-string n) (elt k i)) (setf n (1+ n)))))) -(define-ompw numtochar3 (num) +(define-box numtochar3 (num) (declare (ignore num)) (error "default method. should not be called.")) @@ -1103,7 +1102,7 @@ (ac (append (reverse seqr) seq) lisse1 (1- prof) (1+ level) lisse2)))))) -(define-ompw rma-1 ((seq nil) (smoo1 1) (levels 1) &optional (smoo2 0) +(define-box rma-1 ((seq nil) (smoo1 1) (levels 1) &optional (smoo2 0) (alpha? 1) (result 0)) " m�me fonction que structure-1, mais r�cursive : @@ -1281,7 +1280,7 @@ (defun list-char-score (lcs) (setf (car lcs) (list (make-string 1 :initial-element (car lcs)) (cadr lcs)))) -(define-ompw rma-1-scores ((structures nil)) +(define-box rma-1-scores ((structures nil)) "Returns the score of each structure, level by level of the rma-1 analysis." :non-generic t (let ((types (mapcar 'test-eq-l structures)) (scores nil) (s nil)) @@ -1374,7 +1373,7 @@ (setf pat (append pat (list (nth (+ n o) seq))))) (when (equalp pat ptrn) (push n pos-p))))) -(define-ompw pos-ptrn-l ((lptrn nil) (seq nil) &optional (min 2) (max 12)) +(define-box pos-ptrn-l ((lptrn nil) (seq nil) &optional (min 2) (max 12)) "Gives all positions in seq where starts ptrns. INPUT : lptrn : list of patterns to be found; @@ -1442,7 +1441,7 @@ (flet ((match (x) (and (<= val (max-dom x)) (>= val (min-dom x))))) (position-if #'match list-dom))) -(define-ompw ins-ptrn ((seq (1 2 3 4 1 2 5 3 4)) (ptrn ((1 2 3 4) (1 2))) +(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 0)) "Finds the pattern(s) PTRN in list seq with or without up to a number prof inserted items; @@ -1532,7 +1531,7 @@ (push (list pattern (reverse pos)) r)))) -(define-ompw structure-2 ((seq nil) (n-max 10) (alpha? 1) (result 0) &optional +(define-box structure-2 ((seq nil) (n-max 10) (alpha? 1) (result 0) &optional (length nil) (seuil 10)) "INPUT seq = sequence of nums or symbols; @@ -1662,7 +1661,7 @@ (push (OM::posn-match list-of-pat k) ros)))) (mat-trans (list calcolo calcolaccio)))) -(define-ompw forma ((analys nil) (seq nil) (seuil 1)) +(define-box forma ((analys nil) (seq nil) (seuil 1)) :non-generic t (let ((r nil)) (dolist (l analys (reverse r)) @@ -1724,7 +1723,7 @@ "~%computation time : ~,3F seconds~%~% End of Pattern Analysis (Structure-2)~%" run-time)) -(define-ompw aver-class ((seq nil) (class nil)) +(define-box aver-class ((seq nil) (class nil)) "Return the average center of classes (one dimension)." :non-generic t (let ((r nil) (rt nil) (length (remove-duplicates class))) @@ -1741,7 +1740,7 @@ 10000)))))) -(define-ompw quantize-1 ((seq nil) (class nil)) +(define-box quantize-1 ((seq nil) (class nil)) "Returns the quantization of elements in list according to the classification defined in class (one dimension)" :non-generic t @@ -1761,7 +1760,7 @@ (dolist (n class (reverse rt)) (push (nth n r) rt)))) -(define-ompw l-matrix ((list nil)) +(define-box l-matrix ((list nil)) "Makes a matrix from a list of lists." :non-generic t (let ((mat @@ -1775,7 +1774,7 @@ (setf (aref mat l m) (nth m (nth l list)))))))) -(define-ompw class-1 ((matrix nil) (n 2) &optional (alpha? 0) (centers nil) +(define-box class-1 ((matrix nil) (n 2) &optional (alpha? 0) (centers nil) (verbose "no")) "Clustering 'mouving-clouds' algorithm. Classify elements in matrix of d-dimensions into n classes. The nth element in result-list corresponds @@ -1880,7 +1879,7 @@ (dotimes (j m) (setf sum (+ sum (aref x j i)))) (setf (aref g 0 i) (float (/ sum m)))))) -(define-ompw matrix-center ((matrix nil)) +(define-box matrix-center ((matrix nil)) "Donne les coordonn�es du centre de gravit� d'une matrice des coordonn�es de points en n-dimensions (utiliser l-matrix pour convertir une liste de coordonn�es de points en matrice). @@ -1924,7 +1923,7 @@ (const*matrix (/ 1 (car (array-dimensions matrix))) (multiply-two-matrices (transpose matrix) matrix))) -(define-ompw dist-euclidienne ((matrix nil)) +(define-box dist-euclidienne ((matrix nil)) "input = matrix of coordinates of points in a d-space; output = upper-matrix of euclidian distances." :non-generic t @@ -1943,7 +1942,7 @@ (setf (aref mat-dist i k) (sqrt temp)))))) -(define-ompw euclidian-d ((matrix nil)) +(define-box euclidian-d ((matrix nil)) "input = matrix of coordinates of points in a d-space; output = upper-matrix of euclidian distances." (let (k @@ -2010,7 +2009,7 @@ (setf tc (CENTRE-GRAVIT\� nuage))))) (dotimes (d *n*) (setf (aref centres b d) (aref tc 0 d)))))) -(define-ompw class-center ((matrix nil) (classes nil)) +(define-box class-center ((matrix nil) (classes nil)) "input = matrix of points in d-dimensions liste of classes founded for each point (line in matrix); Classes must be in numerical representation. @@ -2068,7 +2067,7 @@ (push (/ (length (remove-if-not #'(lambda (x) (equal x ci)) data)) n) p)))) -(define-ompw entropy ((class nil) (res "abs")) +(define-box entropy ((class nil) (res "abs")) "Returns the Shannon entropy value of the data classified. data : list of classes distribution (typically data from class-1); res : absolute or relative entropy; @@ -2117,7 +2116,7 @@ (setf class (str->symb class)) (entropy class res)) -(define-ompw meta-class1 ((matrix nil) (n 2) (iter 1) &optional alpha? centers +(define-box meta-class1 ((matrix nil) (n 2) (iter 1) &optional alpha? centers verbose) "Does n iterations of class-1 algorithm. The classes designation is normalized." @@ -2157,7 +2156,7 @@ (push marker r)) (t (push (- (1- (length set)) (pos (nth c classes) set)) r)))))) -(define-ompw norm-class ((classes nil)) +(define-box norm-class ((classes nil)) "reordonne les classes de class-1. L'ordre de la classe �tant le num�ro de sa premi�re occurence dans la liste des classes. Se connecte typiquement apr�s class-1 ou meta-class1. @@ -2191,7 +2190,7 @@ (dotimes (j (array-dimension mat 1) (push (reverse c) p)) (push (aref mat i j) c)))))) -(define-ompw p-class ((clusters nil)) +(define-box p-class ((clusters nil)) "Give the probability for each to be element of class #" :non-generic t (prob-class clusters)) @@ -2210,7 +2209,7 @@ (when (> (aref prob j i) p) (setf p (aref prob j i)) (setf cl j))) (if (= val? 0) (push cl r) (push (list cl p) r))))) -(define-ompw res-class ((proba nil) (val? 0)) +(define-box res-class ((proba nil) (val? 0)) "Affects each point i of the matrix prob to the class (j) with higher probability." :non-generic t :menu (val? (0 "classes") (1 "proba")) @@ -2225,7 +2224,7 @@ (pos2 e entropies) (mapcar #'(lambda (n) (nth n clusters)) (pos2 e entropies))))) -(define-ompw e-test ((clusters nil) (test "min") &optional (out "clust")) +(define-box e-test ((clusters nil) (test "min") &optional (out "clust")) "Returns the clusters which have the minimum or maximum entropy." :non-generic t :menu (test ("min" "min") ("max" "max")) @@ -2443,7 +2442,7 @@ (remove nil r :key #'third))) (reverse (remove-duplicates r :key #'cadr)))) -(define-ompw min-flex-max ((seq +(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)) @@ -2487,7 +2486,7 @@ (otherwise (error "Got ~s, was expecting one of 1, 2, 3, 4." result))))) -(define-ompw 1-0-1-reconst ((list nil)) +(define-box 1-0-1-reconst ((list nil)) "fonction dx->x d'OM : renvoie une liste de points depuis une liste d'intervalles . commence � zero" @@ -2495,7 +2494,7 @@ (OM::dx->x 0 list)) -(define-ompw reconst-prim (list start) +(define-box reconst-prim (list start) :non-generic t "est la fonction OM dx->x" (let ((ris start) prim prof last) @@ -2514,7 +2513,7 @@ (push (apply prim (list last -1)) ris))))))))) -(define-ompw reconstitute ((list nil) (which 1) (start 0)) +(define-box reconstitute ((list nil) (which 1) (start 0)) "reconstitue le profil original. avec optionnels: prim : n'utilise que l'analyse primitive @@ -2551,7 +2550,7 @@ (otherwise (error "Got ~s, was expecting one of 1, 2, 3, 4." which)))) -(define-ompw reconst-prim+prof ((list nil)) +(define-box reconst-prim+prof ((list nil)) "Ricostruisce la lista usando min, max, flex pi� eventualmente l'indice di profondit�" :non-generic t @@ -2584,7 +2583,7 @@ (mapcar #'(lambda (x) (nth x seq)) (OM::flat risultato)) (OM::flat risultato)))) -(define-ompw struct2-to-seq ((struct nil) (n nil) &optional ptrns) +(define-box struct2-to-seq ((struct nil) (n nil) &optional ptrns) "Reconstruit une s�quence correspondant � la structure donn�e en struct. Optional : reconstruit une s�quence de m�me structure avec les patterns donn�s en ptrns." @@ -2603,7 +2602,7 @@ donn�s en ptrns." (mapcar #'(lambda (i) (rec-st-2 struct i ptrns)) n)) -(define-ompw reconst-prim+prof+val ((list nil) (start 6000)) +(define-box reconst-prim+prof+val ((list nil) (start 6000)) "Ricostruisce la lista usando min, max, flex pi� eventualmente l'indice di profondit�" :non-generic t @@ -2633,7 +2632,7 @@ ris)))) -(define-ompw pos+prim+prof+val ((list nil) (start 6000)) +(define-box pos+prim+prof+val ((list nil) (start 6000)) "Ricostruisce la lista usando min, max, flex pi� eventualmente l'indice di profondit�" :non-generic t @@ -2715,7 +2714,7 @@ (push valore ris)))))) -(define-ompw controlla-ottave ((list1 nil) (list2 nil) (modul 12)) +(define-box controlla-ottave ((list1 nil) (list2 nil) (modul 12)) "studia i casi particolari della melodia in questione se questa � trasposta pi� o meno esattamente" :non-generic t @@ -2733,7 +2732,7 @@ (if (not (equalp (nth x studio) (nth (+ 1 x) studio))) (push 1 ros))))) -(define-ompw controlla-direzioni ((list1 nil) (list2 nil)) +(define-box controlla-direzioni ((list1 nil) (list2 nil)) "Studia gli intervalli di due liste e ne fa una analisi" :non-generic t (let ((ris nil) @@ -2743,7 +2742,7 @@ (when (not (equalp (nth x direzioni1) (nth x direzioni2))) (push 1 ris))))) -(define-ompw controlla-intervalli ((list1 nil) (list2 nil)) +(define-box controlla-intervalli ((list1 nil) (list2 nil)) "Studia gli intervalli di due liste e ne fa una analisi" :non-generic t (let ((ris nil) @@ -2754,7 +2753,7 @@ (push 1 ris))))) -(define-ompw controlla-rapporti ((list1 nil) (list2 nil)) +(define-box controlla-rapporti ((list1 nil) (list2 nil)) "Verifica se le due liste sono identiche nei rapporti interni con una approssimazione di due decimali." :non-generic t @@ -2773,7 +2772,7 @@ (if (equalp rapporto1 rapporto2) 'ok 'no))) -(define-ompw duration-case ((list1 nil) (list2 nil)) +(define-box duration-case ((list1 nil) (list2 nil)) "" :non-generic t (let ((ris nil)) @@ -2784,7 +2783,7 @@ (push 1 ris))))))) -(define-ompw intensity-case ((list1 nil) (list2 nil)) +(define-box intensity-case ((list1 nil) (list2 nil)) "Verifica se le due liste sono identiche nei rapporti interni con una approssimazione di due decimali." :non-generic t @@ -2806,7 +2805,7 @@ (defun mini (l) "Returns the minimum value of a list" (car (sort l '<))) -(define-ompw dist-1-ldl ((seq1 nil) (seq2 nil) (change 1) (ins/sup 1) +(define-box dist-1-ldl ((seq1 nil) (seq2 nil) (change 1) (ins/sup 1) (wgth (1 1 1 1))) "" :non-generic t @@ -2832,7 +2831,7 @@ 2))))))) -(define-ompw dist-2-ldl ((seq1 nil) (seq2 nil) (change 1) (ins/sup 1) (inex 0) +(define-box dist-2-ldl ((seq1 nil) (seq2 nil) (change 1) (ins/sup 1) (inex 0) (wgth (1 1 1 1))) "" :non-generic t @@ -2859,7 +2858,7 @@ 2))))))) -(define-ompw dist-1 ((seq1 nil) (seq2 nil) (change 1) (ins/sup 1) (scale 1)) +(define-box dist-1 ((seq1 nil) (seq2 nil) (change 1) (ins/sup 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 @@ -2902,7 +2901,7 @@ (format t "~% try arguments 'relative or 'absolute"))))) -(define-ompw dist-2 ((seq1 nil) (seq2 nil) (change 1) (ins/sup 1) (inex 0) +(define-box dist-2 ((seq1 nil) (seq2 nil) (change 1) (ins/sup 1) (inex 0) (scale 1)) "Returns the smallest distance between two lists of symbols seq1 and seq2 Args : @@ -2969,7 +2968,7 @@ (format t "~% try arguments : 'relative or 'absolute"))))) -(define-ompw distance ((seq1 (a b c d e)) (seq2 (a b c d e)) (change 1) +(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)) "Returns the smallest distance between two lists of symbols seq1 and seq2 Args : @@ -2986,7 +2985,7 @@ (dist-1 seq1 seq2 change ins/sup scale))) -(define-ompw multi-distance ((seq1 nil) (seq2 nil) (change 1) (ins/sup 1) +(define-box multi-distance ((seq1 nil) (seq2 nil) (change 1) (ins/sup 1) (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) @@ -2997,7 +2996,7 @@ (dist-1-ldl seq1 seq2 change ins/sup wgth))) -(define-ompw resemblance-match (a b) +(define-box resemblance-match (a b) (declare (ignore a b)) (error "default method. should not be called.")) @@ -3017,7 +3016,7 @@ (defun ref-position (list) (mapcar #'(lambda (e) (position e list :test #'equalp)) list)) -(define-ompw resemblance ((a nil) (b nil) (wocc 1.0) (wref 1.0) &optional +(define-box resemblance ((a nil) (b nil) (wocc 1.0) (wref 1.0) &optional (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. @@ -3071,7 +3070,7 @@ (dotimes (x (- (length lista) 1) (nreverse ris)) (push (/ (+ (nth x lista) (nth (1+ x) lista)) 2) ris)))) -(define-ompw 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 @@ -3082,7 +3081,7 @@ (if note? con-note calcolo))) -(define-ompw der ((lista nil) (n 0)) +(define-box der ((lista nil) (n 0)) "Crea la media tra una lista di valori diviso n" :non-generic t (let ((ris nil)) @@ -3090,7 +3089,7 @@ (push (remove nil (nth x (scom lista n))) ris)))) -(define-ompw med-var ((lista nil) (windw 1)) +(define-box med-var ((lista nil) (windw 1)) "Restituisce la derivata data dalla media delle note decise in n." :non-generic t (let ((ris nil) (calcolo (der lista windw))) @@ -3098,7 +3097,7 @@ (push (/ (apply '+ (nth x calcolo)) (length (nth x calcolo))) ris)))) -(define-ompw 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 @@ -3107,7 +3106,7 @@ (variable-derivation (med-var lista windw) (- GR\� 1) windw))) -(define-ompw notes-change ((pits 6000) (scale 6000) &optional (mod 12)) +(define-box notes-change ((pits 6000) (scale 6000) &optional (mod 12)) "Cambia un p^rofilo con le note messe in scale." :non-generic t (let* ((pits (list! pits)) @@ -3134,7 +3133,7 @@ octa))) -(define-ompw octave ((midic 6000)) +(define-box octave ((midic 6000)) "retourne l'octave � partir de c3=octave 3" :non-generic t (let ((midic (list! midic))) @@ -3142,7 +3141,7 @@ midic))) -(define-ompw makenote ((index 60) (octave 3) &optional (mod 12)) +(define-box makenote ((index 60) (octave 3) &optional (mod 12)) " construction d'une note � partir des donn�es de index, octave e modulo du index" :non-generic t @@ -3160,7 +3159,7 @@ (nth y lista2)) ros)))) -(define-ompw inter-profile ((list1 nil) (list2 nil)) +(define-box 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))) @@ -3178,7 +3177,7 @@ (last list1))))) -(define-ompw prof-inter ((list1 nil) (list2 nil) (total 1)) +(define-box prof-inter ((list1 nil) (list2 nil) (total 1)) "Restituisce l'interposizione di list1 con list2. Se list1 � pi� piccola di list2 allora la funzione crea un'interposizione di n elementi di list2 dove (= n (- (length list1) 1)). In questo caso si puo' decidere con il @@ -3193,7 +3192,7 @@ (otherwise (error "Got ~s, was expecting one of 1, 2." total)))) -(define-ompw 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 @@ -3203,7 +3202,7 @@ (permut-circ list2 (1- (length list1))) (- GR\� 1)))) -(define-ompw new-inter-profile ((list1 nil) (list2 nil)) +(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))) @@ -3224,7 +3223,7 @@ (last list1))))) -(define-ompw 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 @@ -3272,7 +3271,7 @@ (y)) ris)))) -(define-ompw correttore ((elmt 1) (range nil)) +(define-box correttore ((elmt 1) (range nil)) "Restituisce un elemento se questo compare all'interno del range. Se l'elemento � escluso allora lo traspone in modo tale che sia il pi� vicino possibile o al limite superiore o a quello inferiore. @@ -3301,7 +3300,7 @@ (dolist (y elmt) (push (correttore y range) ris)) (nreverse ris))) -(define-ompw trans-approx ((list nil) (range nil)) +(define-box trans-approx ((list nil) (range nil)) "E' meglio di transpoct di Esquisse. Infatti attua lo stesso procedimento ma traspone una nota non inclusa nel range il pi� vicino o al limite superiore o a quello inferiore." @@ -3309,7 +3308,7 @@ (cor-ott-list (mio-transpoct list range) range)) -(define-ompw direct-analysis ((list (6000 4000 6900 7300 6100 5900))) +(define-box direct-analysis ((list (6000 4000 6900 7300 6100 5900))) "donne le signe de la d�riv�e locale (-1. 0 +1) pour chaque point de la liste des valeurs donn�es en entr�e." :non-generic t @@ -3350,7 +3349,7 @@ 1200))))) ris))))) -(define-ompw malt-mod+ ((list nil) (limit 6000)) +(define-box malt-mod+ ((list nil) (limit 6000)) "" :non-generic t (let ((ris nil) (limite (first (list! limit)))) @@ -3363,7 +3362,7 @@ se non � incluso." (if (<= (g-min range) elmt (g-max range)) elmt nil)) -(define-ompw malt-mod- ((list nil) (limit 6000)) +(define-box malt-mod- ((list nil) (limit 6000)) "" :non-generic t (let ((ris nil) (limite (first (list! limit)))) @@ -3371,7 +3370,7 @@ (push (if (> y limite) (- (* 2 limite) y) y) ris)))) -(define-ompw reflex-int ((ls nil) (value 0) (up/down 1)) +(define-box reflex-int ((ls nil) (value 0) (up/down 1)) "Restituisce la rifleesione delle note che sono superiori o inferiori al valore indicato con 'value'. Il men� permette di selezionare se si vuole una riflessione superiore o inferiore" @@ -3403,7 +3402,7 @@ (first (int-com (list (first asse) (nth x ls)))))) ris)))) -(define-ompw reflex-note ((ls nil) (value 0) (up/down 1)) +(define-box reflex-note ((ls nil) (value 0) (up/down 1)) "Restituisce per la riflessione superiore con UP e quella inferiore con DOWN>" :non-generic t @@ -3414,14 +3413,14 @@ (otherwise (error "Got ~s, was expecting one of 1, 2." up/down)))) -(define-ompw doppio-reflex-note ((list nil) (value nil)) +(define-box doppio-reflex-note ((list nil) (value nil)) "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)) +(define-box doppio-reflex-int ((list nil) (value nil)) "Restituisce due volte REFLEX-INT la prima volta a LIST la seconda volta al risultato della prima volta." :non-generic t @@ -3430,7 +3429,7 @@ (defun int (elt coppia) (if (< (first coppia) elt (second coppia)) elt nil)) -(define-ompw pass-band ((lista nil) (alt nil)) +(define-box pass-band ((lista nil) (alt nil)) "Restituisce i valori inclusi in ALT." :non-generic t (let ((ris nil)) @@ -3438,7 +3437,7 @@ (if (equalp (int x alt) nil) (int x alt) (push x ris))))) -(define-ompw correttore-doppio-reflex-note ((list nil) (value nil) (inclu? 1)) +(define-box 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 oltre i limiti stessi ma con TRANS-APPROX altrimenti le note @@ -3453,7 +3452,7 @@ (otherwise (error "Got ~s, was expecting one of 1, 2." inclu?))))) -(define-ompw correttore-doppio-reflex-int ((list nil) (value nil)) +(define-box correttore-doppio-reflex-int ((list nil) (value nil)) "Corregge il risultato di 'DOPPIO-REFLEX-INT' in modo che se il risultato di 'DOPPIO-REFLEX-INT supera i limiti dati ripete l'operazione di adattamento fino a che non soddisfa @@ -3467,7 +3466,7 @@ ris)))) -(define-ompw reflexion ((list nil) (axis 6000) (mode? 1) (up/down 1)) +(define-box reflexion ((list nil) (axis 6000) (mode? 1) (up/down 1)) "" :non-generic t :menu (mode? (1 "intrv") (2 "note")) @@ -3481,7 +3480,7 @@ up/down)) -(define-ompw double-reflect ((list nil) (limits 6000) (mode? 1) (inclu? 1)) +(define-box double-reflect ((list nil) (limits 6000) (mode? 1) (inclu? 1)) "" :non-generic t :menu (mode? (1 "intrv") (2 "note")) @@ -3492,7 +3491,7 @@ (otherwise (error "Got ~s, was expecting one of 1, 2." mode?)))) -(define-ompw comp-octave ((list nil) (range nil)) +(define-box comp-octave ((list nil) (range nil)) "Restituisce una trasposizione della lista mantenendo le altezze assolute all'interno del 'range. Se un elemento non � incluso nel 'range', allora viene tolto dal risultato." @@ -3502,7 +3501,7 @@ (if (equalp (interno y range) nil) (interno y range) (push y ris))))) -(define-ompw rtm-change ((rhyt nil) (modulo nil) (mode? 1)) +(define-box 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 @@ -3516,7 +3515,7 @@ (otherwise (error "Got ~s, was expecting one of 1, 2." mode?))))) -(define-ompw rtm-change-1 ((rhytm nil) (vals nil)) +(define-box rtm-change-1 ((rhytm nil) (vals nil)) "Se in vals c'� un solo valore allora calcola una approssimazione ritmica in modo tale che tutti i valori risultino un multiplo di vals. Se invece in vals c'� una @@ -3526,7 +3525,7 @@ (let ((vals (list! vals))) (vicini-valori vals rhytm))) -(define-ompw distanza-modulo ((list nil) (modulo nil)) +(define-box distanza-modulo ((list nil) (modulo nil)) "Caclola per ogni elemento della lista list il modulo corrispondente per ogni elemento della lista Modulo e li raggruppa in sotto-liste." @@ -3536,7 +3535,7 @@ (dolist (x modulo) (push (mod y x) ris))))) -(define-ompw usa-quel-modulo ((list nil) (moduli nil)) +(define-box usa-quel-modulo ((list nil) (moduli nil)) "Restituisce i valori che sono tutti multupli dei moduli messi in Moduli." :non-generic t @@ -3547,7 +3546,7 @@ (push (- (nth x list) (g-min (nth x calcolo))) ris))))) -(define-ompw rtm-change-1val ((rht nil) (val 1)) +(define-box rtm-change-1val ((rht nil) (val 1)) "Questa funzione prende ogni elemento di rht e restituisce lo stesso elemento se il (mod rht val) � uguale a 0 altrimenti lo approssima al po� vicino" @@ -3559,7 +3558,7 @@ (push (- y (OM::om// y val)) ris))))) -(define-ompw tutti-int ((list nil) (ref 1)) +(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 @@ -3569,14 +3568,14 @@ (push (OM::x->dx (list ref y)) ris))))) -(define-ompw segno+picc ((list nil)) +(define-box segno+picc ((list nil)) "Trasforma tutta la lista in valori tutti positivi e prende il valore pi� piccolo." :non-generic t (g-min (mapcar #'(lambda (x) (abs x)) list))) -(define-ompw nota-vicina ((list nil) (ref 1)) +(define-box nota-vicina ((list nil) (ref 1)) "Prende l'intervallo pi� piccolo di una lista." :non-generic t (let* ((intervalli (tutti-int list ref)) (piccolo (segno+picc intervalli))) @@ -3585,19 +3584,19 @@ (nota-vicina (rest list) ref)))) -(define-ompw tieni-nota ((list nil) (ref 1)) +(define-box tieni-nota ((list nil) (ref 1)) "tiene la nota pi� vicina." :non-generic t (OM::om+ ref (nota-vicina list ref))) -(define-ompw vicini-valori ((list1 nil) (refs nil)) +(define-box vicini-valori ((list1 nil) (refs nil)) "Prende le note pi� vicine di list per ogni nota di refs." :non-generic t (mapcar #'(lambda (x) (tieni-nota list1 x)) refs)) -(define-ompw arithm-ser2 ((begin 0) (step 1) (xval 5)) +(define-box arithm-ser2 ((begin 0) (step 1) (xval 5)) "Returns a list of XVAL numbers starting from BEGIN with STEP." :non-generic t (algeb begin xval step)) @@ -3613,7 +3612,7 @@ (push (read input-stream) r)) (cddar (reverse r)))) -(define-ompw f0-additive ((step 1) &optional (range (10 4000))) +(define-box f0-additive ((step 1) &optional (range (10 4000))) "Reads f0 additive analysis. step = reads each values at step window (default = 1 (all); range = returns only values (date and frequency) @@ -3639,7 +3638,7 @@ (mat-trans (list (reverse dates) (reverse f0)))))) -(define-ompw pi-dur ((dates nil) (pitches nil) (min 0) (unit 1)) +(define-box pi-dur ((dates nil) (pitches nil) (min 0) (unit 1)) "Calculates de durations of the pitches according to a change in pitch" :non-generic t :menu (unit (1 "sec") (1000 ".001") (10 "1/100")) @@ -3703,7 +3702,7 @@ (let ((r nil)) (dolist (x wlist (nreverse r)) (dotimes (n (/ w 2)) (push x r))))) -(define-ompw smooth ((list nil) (window 2) (mode 1) &optional (start 0) (end 0)) +(define-box smooth ((list nil) (window 2) (mode 1) &optional (start 0) (end 0)) "Smooth list. INPUT: list : list of values @@ -3790,7 +3789,7 @@ (setf arete (nth n dist))))) arete)) -(define-ompw prim-tree ((dist nil)) +(define-box prim-tree ((dist nil)) "Builds up the shorter tree of the points given in the matrix of distances (list of list), distances must be expressed as ((xi yi di) etc.). prend en entr�e la sortie de ldl-distance en mode extend. @@ -3892,7 +3891,7 @@ (when (> (length substituted) 0) (push (list father substituted) list-of-subst)))))) -(define-ompw s-class ((seq nil) (dist nil) (thresh 0)) +(define-box s-class ((seq nil) (dist nil) (thresh 0)) "Substitute each elt of sequence by its nearest if their distance is equal or lower than threshold and according to the Prim's minimum length tree. Returns the new sequence with substitution and a list of (by (replaced ....))." @@ -3900,7 +3899,7 @@ (substitute-seuil seq dist thresh)) -(define-ompw delta ((list nil) (round 1000)) +(define-box delta ((list nil) (round 1000)) " calcule les diff�rences entre les valeurs cons�cutives avec un arrondi " :non-generic t (let ((l nil) (delta nil)) @@ -3914,7 +3913,7 @@ (remarkable-nodes :initform nil :initarg :remarkable-nodes :accessor remarkable-nodes))) -(define-ompw draw-tree ((tree nil) &optional (nodes nil) (name nil) +(define-box 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. @@ -3949,7 +3948,7 @@ tree-wind)) -(define-ompw set-wintree-font (win fontname fontsize fontstyle) +(define-box set-wintree-font (win fontname fontsize fontstyle) (declare (ignore win fontname fontsize fontstyle)) (error "default method. should not be called.")) @@ -3985,7 +3984,7 @@ (fontsize integer) (fontstyle t)) (set-view-font win (list "times" fontsize :bold))) -(define-ompw view-draw-contents (self) +(define-box view-draw-contents (self) :non-generic t (call-next-method) (let ((h (point-h (view-size self))) (v (point-v (view-size self)))) @@ -3994,7 +3993,7 @@ (make-graph-tree self (tree self) (remarkable-nodes self)))) -(define-ompw window-grow-event-handler (self where) +(define-box window-grow-event-handler (self where) :non-generic t (call-next-method) (invalidate-view self)) @@ -4098,7 +4097,7 @@ x)) coord)))) -(define-ompw ndigit (num) +(define-box ndigit (num) 1) (defmethod ndigit ((num integer)) @@ -4234,7 +4233,7 @@ (dolist (d dist) (nsubstitute (nth n flags) (nth n list) d :test #'equalp)))) -(define-ompw rep-by-flag (dist list flags) +(define-box rep-by-flag (dist list flags) :non-generic t (rep-by-flag1 dist list flags)) @@ -4370,7 +4369,7 @@ (mapcar #'lul1 (extr-to-extr3 start extremites noeuds)))))) (subseq long-path 0 (1+ (position end long-path :test #'equalp)))))) -(define-ompw path (tree start end) +(define-box path (tree start end) (declare (ignore tree start end)) (error "default method. should not be called.")) @@ -4437,7 +4436,7 @@ (fflat ldl) (lul1 (append (list (lul (car ldl) (cadr ldl))) (cddr ldl))))) -(define-ompw tree-path ((tree nil) (start nil) (end nil)) +(define-box 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) or lists of atoms. @@ -4466,7 +4465,7 @@ (setf (symbol-value name) (make-hash-table :size length))) (print name)) -(define-ompw data-base (name action &optional length) +(define-box data-base (name action &optional length) :non-generic t list "" @@ -4487,7 +4486,7 @@ I was not able to translate this function. Rewrite it by hand! :-P")) -(define-ompw add-to-data (name) +(define-box add-to-data (name) :non-generic t list ""

1 0

[Morphologie-cvs] r14 - trunk/src
by ksprotte＠common-lisp.net 06 Jul '07

06 Jul '07

Author: ksprotte Date: Fri Jul 6 04:16:32 2007 New Revision: 14 Modified: trunk/src/morphologie.lisp Log: changes for new OMPW - you need at least 0.2.0 Modified: trunk/src/morphologie.lisp ============================================================================== --- trunk/src/morphologie.lisp (original) +++ trunk/src/morphologie.lisp Fri Jul 6 04:16:32 2007 @@ -33,6 +33,9 @@ ;; :do (push (remove nil (nreverse (svref vector i))) res)) ;; (nreverse res))) +(def-menu morphologie) +(in-menu morphologie) + (define-ompw list-modulo (list &optional ncol) "partitions LIST in NCOL lists containing the elements modulo NCOL" :non-generic t @@ -72,6 +75,7 @@ (define-ompw g-min (list) :non-generic t + :export nil ; just for trying things out, we exclude this from the menu (less-deep-mapcar #'the-min (list! list))) @@ -361,6 +365,7 @@ (mapcar #'car r) (mapcar #'(lambda (x) (mapcar #'car x)) r))))))) +(menu-separator) (define-ompw 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") @@ -4487,3 +4492,10 @@ list "" (add-to-datase name)) + +;;; just a test - I will remove it +(menu-separator) +(menu-add-symbol +) + +(install-menu morphologie) +

1 0

[Morphologie-cvs] r13 - trunk/src
by ksprotte＠common-lisp.net 05 Jul '07

05 Jul '07

Author: ksprotte Date: Thu Jul 5 12:27:57 2007 New Revision: 13 Added: trunk/src/package.lisp trunk/src/utils.lisp Log: added two files Added: trunk/src/package.lisp ============================================================================== --- (empty file) +++ trunk/src/package.lisp Thu Jul 5 12:27:57 2007 @@ -0,0 +1,4 @@ +(defpackage :morphologie + (:use :cl :ompw) + (:nicknames :morph)) + Added: trunk/src/utils.lisp ============================================================================== --- (empty file) +++ trunk/src/utils.lisp Thu Jul 5 12:27:57 2007 @@ -0,0 +1,72 @@ +(in-package :morph) + +(defun list! (thing) + (if (listp thing) thing (list thing))) + +(defun mat-trans (matrix) + (assert (apply #'= (mapcar #'length matrix)) nil + "this should not happen. Please report this to Kilian Sprotte") + (when matrix (apply #'mapcar #'list matrix))) + +(defun group-list (list segmentation mode) + "Segments a <list> in successives sublists +which lengths are successive values of the list <segmentation>. + <mode> indicates if <list> is to be read in a circular way." + (let ((list2 list) (res nil)) + (catch 'gl + (loop for segment in segmentation + while (or list2 (eq mode 'circular)) + do (push (loop for i from 1 to segment + when (null list2) + do (ecase mode + (linear (push sublist res) (throw 'gl 0)) + (circular (setf list2 list))) + end + collect (pop list2) into sublist + finally (return sublist)) + res))) + (nreverse res))) + +(defun flat-once (list) + (if (consp (car list)) + (apply 'append list) list)) + +#-(or lispworks digitool) +(defun choose-new-file-dialog (&key (prompt "Enter the path for a new file:") + button-string) + (declare (ignore button-string)) + (format *query-io* "~&~a~%[please enter a path like /tmp/test.txt]~%" prompt) + (force-output *query-io*) + (parse-namestring (read-line *query-io*))) + +#+digitool +(defun choose-new-file-dialog (&key (prompt "Enter the path for a new file:") + button-string) + (ccl::choose-new-file-dialog :prompt prompt :button-string button-string)) + +#+lispworks +(defun choose-new-file-dialog (&key (prompt "Enter the path for a new file:") + button-string) + (capi:prompt-for-file prompt :operation :save)) + +#-(or lispworks digitool) +(defun choose-file-dialog (&key (prompt "Enter the path for an existing file:") + button-string) + (format *query-io* "~&~a~%[please enter a path like /tmp/test.txt]~%" prompt) + (force-output *query-io*) + (let ((path (parse-namestring (read-line *query-io*)))) + (if (probe-file path) + path + (progn + (format *query-io* "~&ERROR: ~A does not exist.~%" path) + (choose-file-dialog :prompt prompt :button-string button-string))))) + +#+digitool +(defun choose-file-dialog (&key (prompt "Enter the path for an existing file:") + button-string) + (ccl::choose-file-dialog :prompt prompt :button-string button-string)) + +#+lispworks +(defun choose-file-dialog (&key (prompt "Enter the path for a new file:") + button-string) + (capi:prompt-for-file prompt))

1 0

[Morphologie-cvs] r12 - in trunk: . src
by ksprotte＠common-lisp.net 05 Jul '07

05 Jul '07

Author: ksprotte Date: Thu Jul 5 11:43:38 2007 New Revision: 12 Modified: trunk/morphologie.asd trunk/src/missing-om-functions.txt trunk/src/morphologie.lisp trunk/src/tests.lisp Log: structure-1 works!! (choose-new-file-dialog too...) Modified: trunk/morphologie.asd ============================================================================== --- trunk/morphologie.asd (original) +++ trunk/morphologie.asd Thu Jul 5 11:43:38 2007 @@ -3,6 +3,9 @@ (defsystem :morphologie :components ((:module :src + :serial t :components - ((:file "morphologie")))) + ((:file "package") + (:file "utils") + (:file "morphologie")))) :depends-on (:ompw)) Modified: trunk/src/missing-om-functions.txt ============================================================================== --- trunk/src/missing-om-functions.txt (original) +++ trunk/src/missing-om-functions.txt Thu Jul 5 11:43:38 2007 @@ -1,4 +1,3 @@ -om::group-list om::dx->x om::arithm-ser om::x-append @@ -17,6 +16,3 @@ om::flat om::x->dx om::om+ -om::flat-once - - Modified: trunk/src/morphologie.lisp ============================================================================== --- trunk/src/morphologie.lisp (original) +++ trunk/src/morphologie.lisp Thu Jul 5 11:43:38 2007 @@ -10,41 +10,41 @@ ;;;* * ;;;************************************************************************************************************* -(defpackage :morph2 (:use :cl :ompw)) +(in-package :morph) -(in-package :morph2) - -;;; watch out for functions like OM::group-list +;;; watch out for functions like OM::.... ;;; still in this file -;;; first some om utils -(defun list! (thing) - (if (listp thing) thing (list thing))) - -(defun mat-trans (matrix) - (assert (apply #'= (mapcar #'length matrix)) nil - "this should not happen. Please report this to Kilian Sprotte") - (when matrix (apply #'mapcar #'list matrix))) -;;; end utils - -(define-ompw list-part (list &optional ncol) - "partitions LIST in NCOL lists containing the elements modulo NCOL" - :non-generic t - (let ((vector (make-array ncol)) res) - (loop :while list - :do (loop :for i :from 0 :to (1- ncol) - :do (and list - (setf (svref vector i) - (push (pop list) (svref vector i)))))) - (loop :for i :from 0 :to (1- ncol) - :do (push (remove nil (nreverse (svref vector i))) res)) - (nreverse res))) +;; I tried to get this version of LIST-MODULO to run - but there is a problem +;; with this code. +;; see my reimplementation below + +;; (define-ompw list-modulo (list &optional ncol) +;; "partitions LIST in NCOL lists containing the elements modulo NCOL" +;; :non-generic t +;; (let ((vector (make-array ncol)) res) +;; (loop :while list +;; :do (loop :for i :from 0 :to (1- ncol) +;; :do (and list +;; (setf (svref vector i) +;; (push (pop list) (svref vector i)))))) +;; (loop :for i :from 0 :to (1- ncol) +;; :do (push (remove nil (nreverse (svref vector i))) res)) +;; (nreverse res))) (define-ompw list-modulo (list &optional ncol) + "partitions LIST in NCOL lists containing the elements modulo NCOL" :non-generic t - (list-part list ncol)) - + ;; new implementation by Kilian + ;; should produce the same result + ;; I assume that NCOL would not be a very + ;; large number - so efficiency should be fine + (let ((result-lists (make-list ncol))) + (loop for i = 0 then (mod (1+ i) ncol) + for elt in list + do (push elt (nth i result-lists))) + (map-into result-lists #'nreverse result-lists))) (defun less-deep-mapcar (fun list? &rest args) "Applies FUN to LIST? ARGS if LIST? is a one-level list . @@ -649,7 +649,7 @@ (setf b1 nil) (setf b1 (append (list (car l)) (n-n-1l l))) (setf b2 (append b1 (list (- (length list) (car (last l)))))) - (push (remove 'nil (OM::group-list list b2 1)) res)) + (push (remove 'nil (group-list list b2 1)) res)) (list (car c) (reverse res)))) (defun segnum1 (seq) @@ -658,7 +658,7 @@ (res1 nil) (res2 nil)) (dotimes (n (length seq1)) (push (list (nth n seq1) (+ n 1)) res1)) - (setf res1 (OM::flat-once (reverse res1))) + (setf res1 (flat-once (reverse res1))) (dotimes (n (length seq)) (setf res2 (member (nth n seq) res1 :test 'equal)) (push (list res2 (second res2)) seq2)) @@ -668,7 +668,7 @@ (let ((seqs (second list)) (a nil) (b nil) (c nil) (res nil)) (dolist (s seqs) (setf c (segnum1 s)) - (setf a (remove-duplicates (OM::flat-once (car c)))) + (setf a (remove-duplicates (flat-once (car c)))) (setf b (cdr c)) (setf a (mat-trans (reverse (list-modulo a 2)))) (push (list a (car b)) res)) @@ -676,7 +676,7 @@ (defun form (segs) (let ((res nil)) - (setf segs (OM::flat-once (cdr segs))) + (setf segs (flat-once (cdr segs))) (dolist (s segs (reverse res)) (push (cadr s) res)))) (defun take-date () @@ -724,7 +724,7 @@ (format stream "~S " (nth n (cadr from-struct-1))) (format stream "~%~%")))) -(define-ompw structure-1 ((seq nil) &optional (alpha? :alpha) (smooth? :yes) +(define-ompw 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)) "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. @@ -788,7 +788,7 @@ (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) + ;; (set-mac-file-creator out-file 'ttxt) (format t "DONE~%")) ((eql :short result) (if (eql :alpha alpha?) @@ -1633,7 +1633,8 @@ :create) (to-stream seq list-patterns seuil formes completion-patterns out-st date run-time)) - (set-mac-file-creator out-file 'ttxt)) + ;; (set-mac-file-creator out-file 'ttxt) + ) ((= result 5) (to-stream-1-jbs list-patterns formes completion-patterns))))))))) @@ -3848,7 +3849,7 @@ (defun tronc (extrem noeuds) (dolist (e extrem - (remove-duplicates (OM::flat-once noeuds) :test 'equalp)) + (remove-duplicates (flat-once noeuds) :test 'equalp)) (dotimes (n (length noeuds)) (setf (nth n noeuds) (remove-if #'(lambda (x) (equalp e x)) (nth n noeuds)))))) Modified: trunk/src/tests.lisp ============================================================================== --- trunk/src/tests.lisp (original) +++ trunk/src/tests.lisp Thu Jul 5 11:43:38 2007 @@ -1,8 +1,13 @@ -(in-package :morph2) +(in-package :morph) (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)) +(assert (equal (list-part '((a b c a b c) 1 (d a c) 2 (d a b c a) 3) 2) + '(((a b c a b c) (d a c) (d a b c a)) (1 2 3)))) + +(assert (equal (list-part '(a b c a b c 1 d a c 2 d a b c a 3) 4) + '((a b a a 3) (b c c b) (c 1 2 c) (a d d a)))) +(structure-1 '(a b c a b c d a c c d a a b c a))

1 0

[Morphologie-cvs] r11 - trunk/src
by ksprotte＠common-lisp.net 05 Jul '07

05 Jul '07

Author: ksprotte Date: Thu Jul 5 10:09:13 2007 New Revision: 11 Modified: trunk/src/morphologie.lisp Log: added ignore to (error "default method. should not be called.") Modified: trunk/src/morphologie.lisp ============================================================================== --- trunk/src/morphologie.lisp (original) +++ trunk/src/morphologie.lisp Thu Jul 5 10:09:13 2007 @@ -10,9 +10,6 @@ ;;;* * ;;;************************************************************************************************************* -;;; please note that this file has been autogenerated -;;; hand editing might not yet make sense - (defpackage :morph2 (:use :cl :ompw)) (in-package :morph2) @@ -193,6 +190,7 @@ Si N est nul (nil), donne tous les segments repetes quelle que soit leur longueur; N peut etre une liste de longueurs souhaitees." + (declare (ignore list n)) (error "default method. should not be called.")) (defmethod ptrn-find ((list list) (n integer)) @@ -526,6 +524,7 @@ (define-ompw str->symb ((strings nil)) "Converts string or list of strings or list of list of strings into list (list of list) of symbols. !! : please replace double quotes by simple quotes before evalution." + (declare (ignore strings)) (error "default method. should not be called.")) (defmethod str->symb ((strings list)) @@ -544,6 +543,7 @@ 1 -> b 2 -> c etc." + (declare (ignore list)) (error "default method. should not be called.")) (defmethod num->alpha ((list list)) @@ -563,6 +563,7 @@ (numtochar0 list)) (define-ompw minirec (list) + (declare (ignore list)) (error "default method. should not be called.")) (defmethod minirec ((list number)) list) @@ -868,6 +869,7 @@ (defun modulo26 (num) (values (mod num 26) (floor (/ num 26)))) (define-ompw numtochar (num) + (declare (ignore num)) (error "default method. should not be called.")) (defmethod numtochar ((num integer)) @@ -883,6 +885,7 @@ (defmethod numtochar ((num list)) (mapcar #'numtochar num)) (define-ompw numtochar0 (num) + (declare (ignore num)) (error "default method. should not be called.")) (defmethod numtochar0 ((num integer)) @@ -898,6 +901,7 @@ (defmethod numtochar0 ((num list)) (mapcar #'numtochar0 num)) (define-ompw numtochar2 (num) + (declare (ignore num)) (error "default method. should not be called.")) (defmethod numtochar2 ((num integer)) (numtochar num)) @@ -916,6 +920,7 @@ (setf n (1+ n)))))) (define-ompw numtochar3 (num) + (declare (ignore num)) (error "default method. should not be called.")) (defmethod numtochar3 ((num integer)) (numtochar num)) @@ -1772,6 +1777,7 @@ The classe number is arbitrary" :menu (alpha? (1 "alpha") (0 "num")) :menu (verbose ("no" "no") ("yes" "yes")) + (declare (ignore matrix n)) (error "default method. should not be called.")) (defmethod class-1 ((matrix array) (n integer) &optional (alpha? 0) @@ -2067,6 +2073,7 @@ Cf. J. Wasemberg : L �me de la m�duse, id�es sur la complexit� du monde, Seuil, Paris, 1997." :menu (res ("abs" "absolute") ("rel" "relative")) + (declare (ignore class res)) (error "default method. should not be called.")) (defmethod entropy ((class list) (res string)) @@ -2575,6 +2582,7 @@ "Reconstruit une s�quence correspondant � la structure donn�e en struct. Optional : reconstruit une s�quence de m�me structure avec les patterns donn�s en ptrns." + (declare (ignore struct n)) (error "default method. should not be called.")) (defmethod struct2-to-seq ((struct list) (n integer) &optional ptrns) @@ -2984,6 +2992,7 @@ (define-ompw resemblance-match (a b) + (declare (ignore a b)) (error "default method. should not be called.")) (defmethod resemblance-match ((a symbol) (b symbol)) (if (equalp a b) 1 0)) @@ -3009,6 +3018,7 @@ Wocc : poids de la structure d'occurence; Wref : poids de la structure de repetition." :menu (diff ("res" "res") ("diss" "diss")) + (declare (ignore a b wocc wref)) (error "default method. should not be called.")) (defmethod resemblance ((a list) (b list) (wocc float) (wref float) &optional @@ -3934,6 +3944,7 @@ (define-ompw set-wintree-font (win fontname fontsize fontstyle) + (declare (ignore win fontname fontsize fontstyle)) (error "default method. should not be called.")) (defmethod set-wintree-font ((win tree-window) (fontname string) @@ -4354,6 +4365,7 @@ (subseq long-path 0 (1+ (position end long-path :test #'equalp)))))) (define-ompw path (tree start end) + (declare (ignore tree start end)) (error "default method. should not be called.")) (defmethod path ((tree list) (start null) (end null))

1 0

[Morphologie-cvs] r10 - in trunk: . src
by ksprotte＠common-lisp.net 05 Jul '07

05 Jul '07

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

1 0

[Morphologie-cvs] r8 - trunk/src
by ksprotte＠common-lisp.net 01 Jul '07

01 Jul '07

Author: ksprotte Date: Sun Jul 1 15:51:08 2007 New Revision: 8 Modified: trunk/src/morphologie.lisp Log: added doc Modified: trunk/src/morphologie.lisp ============================================================================== --- trunk/src/morphologie.lisp (original) +++ trunk/src/morphologie.lisp Sun Jul 1 15:51:08 2007 @@ -107,6 +107,7 @@ (define-ompw primo-passo ((lista nil) (n 1)) + "prende n elementi di una lista" :non-generic t (let ((f nil)) (dotimes (x n) (push (nth x lista) f)) @@ -114,6 +115,7 @@ (define-ompw scom ((lista1 nil) &optional (n nil)) + "Scompone la lista1 in funzione delle lunghezze indicate nella n" :non-generic t (let ((ris nil)) (cond @@ -133,6 +135,8 @@ (define-ompw pattern-ridond ((lista nil) &optional (n nil)) + "Restituisce tutte le ripetizioni di tutti i sotto-pattern in + cui può essere scomposta la sequenza in lista." :non-generic t (let ((ris nil) (x (scom lista n)) y) (loop :while x :do @@ -141,6 +145,7 @@ (define-ompw ptrn-recogn ((list (1 2 3 1 2 3 1 2 1 2))) + "restituisce..." :non-generic t (let* ((ris nil) (ros nil) @@ -154,11 +159,15 @@ (define-ompw rispero ((lista (1 2)) (n 0)) + "E' come spero solo che divide la + lista in base al valore messo in n" :non-generic t (scom lista n)) (define-ompw risperiamo ((lista nil) (n 0)) + "E' molto simile a speriamo : trova i pattern di n lunghezza + all'interno della lista" :non-generic t (let ((ris nil)) (dolist (x (rispero lista n) (nreverse ris)) @@ -166,6 +175,9 @@ (define-ompw ptrn-ridond-ctrl-prov ((lista nil) (n nil)) + "Restituisce tutti i sotto-pattern che compaiono almeno + due volte (ridondanza) e le cui length sono decise da + noi in N." :non-generic t (let ((ris nil) (x (risperiamo lista n)) y) (loop :while x :do (if (find (setf y (pop x)) x :test 'equal) (push y ris))) @@ -223,6 +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> . +Renvoie pour chaque fenêtre le nombre d'occurrences d'un élément. +L'entrée optionnelle <set> specifie les segments recherches dans <list>." :non-generic t (count-ptrn-win list windw step set)) @@ -260,6 +276,9 @@ result-not-sorted))))))) (define-ompw ptrn-smooth ((list (a b c d b b))) + "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 (let ((l nil)) (loop for x from 0 to (1- (length list)) do @@ -315,6 +334,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 + 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>. + +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 +(if 'nil, length = 2); +<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)) @@ -330,6 +364,16 @@ (define-ompw 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")) + "Estimates the distances between lists of symbols. +INPUT +l-seq : list of lists of symbols; +change : cost when changing a symbol; +ins/sup : cost when inserting or deleting a symbol; +inex : added cost when the edition is made on a symbol not actual in the other list; +scale : scaling of the distance (ABSOLUTE / RELATIVE), default : ABSOLUTE; +result : output mode - list of list (short), easy-to-read mode (extended) or save to file (save). +OUTPUT +A matrix of distances" :non-generic t :menu (scale ("rel" "relative") ("abs" "absolute")) :menu (result ("short" "short") ("ext" "extended") ("save" "save")) @@ -565,6 +609,7 @@ (define-ompw concatstrings ((lofstrings nil)) + "Concantenates list of strings into one string." :non-generic t (let ((concatenated (make-string (apply #'+ (mapcar #'length lofstrings)) :initial-element @@ -581,6 +626,7 @@ (string-to-symbol (mc-to-name midiseq approx))) (define-ompw midiseq->alpha ((midiseq nil) (approx 0)) + "Converts midicents values into symboles." :non-generic t (midiseq->alpha1 midiseq approx)) @@ -659,6 +705,24 @@ (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 . +result : menu déroulant, quatre possibilités : + short = liste des critères de segmentation et leur segmentation respective; + exten = analyse détaillée; + + save = analyse détaillée écrite en un fichier texte. + +OUTPUT +en mode short, pour le traitement de l'analyse, liste de liste selon le format : + +((critères de segmentation) +(forme selon critère)...)" :non-generic t :menu (alpha? ("alpha" "alpha") ("num" "num")) :menu (smooth? ("yes" "yes") ("no" "no")) @@ -997,6 +1061,12 @@ (define-ompw rma-1 ((seq nil) (smoo1 1) (levels 1) &optional (smoo2 0) (alpha? 1) (result 0)) + " +même fonction que structure-1, mais récursive : +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." :non-generic t (when (< levels 1) (format t "Recursion error : levels must be >= 1 !~%") @@ -1149,6 +1219,7 @@ (setf (car lcs) (list (make-string 1 :initial-element (car lcs)) (cadr lcs)))) (define-ompw rma-1-scores ((structures nil)) + "Returns the score of each structure, level by level of the rma-1 analysis." :non-generic t (let ((types (mapcar 'test-eq-l structures)) (scores nil) (s nil)) (setf (car types) (mapcar #'remove-duplicates (car types))) @@ -1300,6 +1371,20 @@ (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 +up to a number prof inserted items; +Return each pattern and its start positions. +Doesn't permit cross-overing of a pattern on itself. +Optional-1: + A set (list) of elements which can be inserted in the patterns. + If set empty, no constraint. + When seq is a list of values, permits a list of 'domains' + defined by a list of min and max values. +Optional-2: + If seq is a list of values, definition of a margin around the values, + more and less the value specified in set (+-); + only more the value in set (+); + or only less the value in set (-)." :non-generic t :menu (marg (3 "+-") (1 " + ") (2 " - ")) (let ((val 0) (p 0) (pos nil) (long 0) (r nil) (set2 0)) @@ -1379,6 +1464,27 @@ (define-ompw structure-2 ((seq nil) (n-max 10) (alpha? 1) (result 0) &optional (length nil) (seuil 10)) + "INPUT +seq = sequence of nums or symbols; +n-max = maximum number of patterns accepted in structure of seq; +alpha = alpha or num representation of the resulting structures; +result = type of output of analysis + extended -> detailed analysis; + struct -> returns score, structure and corresponding patterns as list of lists; + pos -> returns only the positions of the patterns; + mat -> return the list of pattern and the associated binary matrix; + p-score -> returns the score of structure completion for each structure; + save -> save all analysis into a file. +&OPTIONAL +length = value or list of minimum and maximum values for length of patterns. + If nil, lengths of patterns are set up to the half-lenght of the sequence; +seuil = minimum completion percentage of the structure taken in account; + +OUTPUT +Returns an analysis of seq according to the repetition criterium to segment. + +Note : if out-of memory, try successives computations with a smaller value +of n-max (max number of patterns combined in each structure" :non-generic t :menu (alpha? (1 "alpha") (0 "num")) :menu (result (0 "extended") (5 "struct") (1 "pos") (2 "mat") (3 "p-score") @@ -1525,6 +1631,7 @@ run-time)) (define-ompw aver-class ((seq nil) (class nil)) + "Return the average center of classes (one dimension)." :non-generic t (let ((r nil) (rt nil) (length (remove-duplicates class))) (dotimes (n (length length)) @@ -1541,6 +1648,8 @@ (define-ompw quantize-1 ((seq nil) (class nil)) + "Returns the quantization of elements in list according to the classification +defined in class (one dimension)" :non-generic t (let ((r nil) (rt nil) (length (remove-duplicates class))) (dotimes (n (length length)) @@ -1559,6 +1668,7 @@ (define-ompw l-matrix ((list nil)) + "Makes a matrix from a list of lists." :non-generic t (let ((mat (if (not (listp (car list))) (make-array (list (length list) 2)) @@ -1682,6 +1792,10 @@ (setf (aref g 0 i) (float (/ sum m)))))) (define-ompw matrix-center ((matrix nil)) + "Donne les coordonnées du centre de gravité d'une matrice + des coordonnées de points en n-dimensions (utiliser l-matrix +pour convertir une liste de coordonnées de points en matrice). +" :non-generic t (let (sum g @@ -1722,6 +1836,8 @@ (multiply-two-matrices (transpose matrix) matrix))) (define-ompw dist-euclidienne ((matrix nil)) + "input = matrix of coordinates of points in a d-space; + output = upper-matrix of euclidian distances." :non-generic t (let (k temp @@ -1739,6 +1855,8 @@ (define-ompw euclidian-d ((matrix nil)) + "input = matrix of coordinates of points in a d-space; + output = upper-matrix of euclidian distances." (let (k temp mat-dist @@ -1807,6 +1925,10 @@ (dotimes (d *n*) (setf (aref centres b d) (aref tc 0 d)))))) (define-ompw class-center ((matrix nil) (classes nil)) + "input = matrix of points in d-dimensions + liste of classes founded for each point (line in matrix); + Classes must be in numerical representation. + output = matrix of classes centers." :non-generic t (let (nuage point @@ -1910,6 +2032,8 @@ (define-ompw meta-class1 ((matrix nil) (n 2) (iter 1) &optional alpha? centers verbose) + "Does n iterations of class-1 algorithm. +The classes designation is normalized." :non-generic t :menu (alpha? ("alpha" "alpha") ("num" "num")) :menu (verbose ("no" "no") ("yes" "yes")) @@ -1945,6 +2069,10 @@ (t (push (- (1- (length set)) (pos (nth c classes) set)) r)))))) (define-ompw norm-class ((classes nil)) + "reordonne les classes de class-1. +L'ordre de la classe étant le numéro de sa première occurence dans la liste des classes. +Se connecte typiquement après class-1 ou meta-class1. +IN : string or list (of symbols or lists or strings)." :non-generic t (if (or (stringp classes) (not (listp (car classes)))) (normalize-class classes) @@ -1977,6 +2105,7 @@ (push (aref mat i j) c)))))) (define-ompw p-class ((clusters nil)) + "Give the probability for each to be element of class #" :non-generic t (prob-class clusters)) @@ -1995,6 +2124,7 @@ (if (= val? 0) (push cl r) (push (list cl p) r))))) (define-ompw res-class ((proba nil) (val? 0)) + "Affects each point i of the matrix prob to the class (j) with higher probability." :non-generic t :menu (val? (0 "classes") (1 "proba")) (resume-class proba val?)) @@ -2008,6 +2138,7 @@ (mapcar #'(lambda (n) (nth n clusters)) (pos2 e entropies))))) (define-ompw e-test ((clusters nil) (test "min") &optional (out "clust")) + "Returns the clusters which have the minimum or maximum entropy." :non-generic t :menu (test ("min" "min") ("max" "max")) :menu (out ("clust" "clust") ("nth" "nth")) @@ -2219,6 +2350,25 @@ (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. +maxima: element précédé et suivi par un élément +de valeur plus petite +flex: element précédé et suivi par un élément +de valeur égale + +ex : (10 8 8 6 6 5 2 2 2 1) +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 + les informations: +prim: succession des primitives +prof: succession des primitives et profondeur en nombre d'éléments de +chaque primitive +vals: idem que prof + valeur correspondant à chaque primitive +every: idem que vals + position de chaque primitive" :non-generic t :menu (result (1 "prim") (2 "prof") (3 "vals") (4 "every")) (let ((primitives (find-primitives seq))) @@ -2242,6 +2392,9 @@ (define-ompw 1-0-1-reconst ((list nil)) + "fonction dx->x d'OM : +renvoie une liste de points depuis une liste + d'intervalles . commence à zero" :non-generic t (OM::dx->x 0 list)) @@ -2266,6 +2419,12 @@ (define-ompw reconstitute ((list nil) (which 1) (start 0)) + "reconstitue le profil original. +avec optionnels: +prim : n'utilise que l'analyse primitive +prof : utilise l'analyse primitive et la profondeur. +vals : utilise l'analyse primitive, la profondeur et la valeur. +every : utilise l'analyse primitive, la profondeur, la valeur et la position " :non-generic t :menu (which (1 "prim") (2 "prof") (3 "vals") (4 "every")) (case which @@ -2297,6 +2456,8 @@ (define-ompw reconst-prim+prof ((list nil)) + "Ricostruisce la lista usando min, max, flex + più eventualmente l'indice di profondità" :non-generic t (let ((ris nil) (start 0)) (dolist

1 0

[Morphologie-cvs] r7 - trunk/src
by ksprotte＠common-lisp.net 01 Jul '07

01 Jul '07

Author: ksprotte Date: Sun Jul 1 15:24:02 2007 New Revision: 7 Modified: trunk/src/morphologie.lisp Log: note Modified: trunk/src/morphologie.lisp ============================================================================== --- trunk/src/morphologie.lisp (original) +++ trunk/src/morphologie.lisp Sun Jul 1 15:24:02 2007 @@ -1,14 +1,17 @@ -;************************************************************************************************************* -;* * -;* Jacopo Baboni Schilingi & Frederic VOISIN * -;* * -;* IRCAM, Paris, november 1998 for Morphologie 1.0 * -;* may 1999 for Morphologie 2.0 * -;* * -;* Fonctions d'analyse, reconnaissance de pattern et classification morphologiques des profiles g�ometriques * -;* Analysis fonctions, pattern recognition and morphological classification of geometric profiles * -;* * -;************************************************************************************************************* +;;;************************************************************************************************************* +;;;* * +;;;* Jacopo Baboni Schilingi & Frederic VOISIN * +;;;* * +;;;* IRCAM, Paris, november 1998 for Morphologie 1.0 * +;;;* may 1999 for Morphologie 2.0 * +;;;* * +;;;* Fonctions d'analyse, reconnaissance de pattern et classification morphologiques des profiles g�ometriques * +;;;* Analysis fonctions, pattern recognition and morphological classification of geometric profiles * +;;;* * +;;;************************************************************************************************************* + +;;; please note that this file has been autogenerated +;;; hand editing might not yet make sense (defpackage "MORPH2")

1 0

[Morphologie-cvs] r6 - trunk/src
by ksprotte＠common-lisp.net 01 Jul '07

01 Jul '07

Author: ksprotte Date: Sun Jul 1 15:19:26 2007 New Revision: 6 Modified: trunk/src/morphologie.lisp Log: added om utils Modified: trunk/src/morphologie.lisp ============================================================================== --- trunk/src/morphologie.lisp (original) +++ trunk/src/morphologie.lisp Sun Jul 1 15:19:26 2007 @@ -1,8 +1,32 @@ +;************************************************************************************************************* +;* * +;* Jacopo Baboni Schilingi & Frederic VOISIN * +;* * +;* IRCAM, Paris, november 1998 for Morphologie 1.0 * +;* may 1999 for Morphologie 2.0 * +;* * +;* Fonctions d'analyse, reconnaissance de pattern et classification morphologiques des profiles g�ometriques * +;* Analysis fonctions, pattern recognition and morphological classification of geometric profiles * +;* * +;************************************************************************************************************* (defpackage "MORPH2") (in-package "MORPH2") +;;; watch out for functions like OM::group-list +;;; still in this file + +;;; first some om utils +(defun list! (thing) + (if (listp thing) thing (list thing))) + +(defun mat-trans (matrix) + (assert (apply #'= (mapcar #'length matrix)) nil + "this should not happen. Please report this to Kilian Sprotte") + (when matrix (apply #'mapcar #'list matrix))) +;;; end utils + (define-ompw list-part (list &optional ncol) "partitions <list> in <ncol> lists containing the elements modulo <ncol>" :non-generic t

1 0

[Morphologie-cvs] r5 - trunk/src
by ksprotte＠common-lisp.net 01 Jul '07

01 Jul '07

Author: ksprotte Date: Sun Jul 1 15:14:11 2007 New Revision: 5 Modified: trunk/src/missing-om-functions.txt Log: a test change Modified: trunk/src/missing-om-functions.txt ============================================================================== --- trunk/src/missing-om-functions.txt (original) +++ trunk/src/missing-om-functions.txt Sun Jul 1 15:14:11 2007 @@ -19,3 +19,4 @@ om::om+ om::flat-once +

1 0