morphologie-cvs
Threads by month
- ----- 2025 -----
- February
- January
- ----- 2024 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2023 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2022 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2021 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2020 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2019 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2018 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2017 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2016 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2015 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2014 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2013 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2012 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2011 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2010 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2009 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2008 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2007 -----
- December
- November
- October
- September
- August
- July
- June
July 2007
- 1 participants
- 20 discussions
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
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
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
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
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
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
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
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
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
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