fred voisin’s website

computer music producer, since 1989

Analyse contrastive en Scheme

30 nov. 2008

Réécrire sur de minuscules machines « handled » de la fin des années 90 des programmes développés sur de luxueuses machines permet de les rendre plus concis et de les optimiser...

La fonction d’analyse contrastive complète est une combinaison des fonctions segs, segpos et edist qui permettent de segmenter une séquence S en une selon chacun des symboles qui la constitue : il s’agit en quelque sorte d’une compression de données « par dictionnaire », où différents segments de S peuvent néanmoins être considérés comme identiques selon un critère de dissimilarité fondé sur leur distance d’édiiton.

segs

map segpos

edist

  • la fonction “segs” regroupe les segments définis par le critère de répétition stricte des différents éléments d’une séquence (on la remplacera avantageursement par l’exemple “map segpos” ci-dessus) ;
  • la fonction “edist” calcul la dissimilarité entre deux séquences (listes) de symboles arbitraires selon l’algorithme de la “distance d’édition” ;
  • la fonction “pom” (« plus ou moins égal ») est la fonction de comparaison de deux chaines de symboles arbitraires selon la distance d’édition (fonction “edist”).

Pour traduire ce code LispMe en Common-Lisp, cf. lispme2lisp.lisp.

code

; AnalyseContrastive
; fred voisin
; Paris-Montbeliard 2008
; dialecte: LispMe

(define (nth n alist)
(if  (< n (length alist))
(list-ref alist n) '()))

(define (neq? a b)
(not (eq? a b)))

(define (rld alist out)
(if (null? out) (rld (cdr alist) (cons (car alist) out))
(if (null? alist)
(reverse out)
(if (neq? (car alist) (car out))
(rld (cdr alist) (cons (car alist) out))
(rld (cdr alist) out)))))

(define (remlocdup alist)
(rld alist '()))

(define (apos alist)
(let ((e (list)))
(do ((i 0 (+ i 1)))
((= i (length alist)) (reverse e))
(let ((m (assoc (nth i alist) e)))
(if m
 (set-cdr! (nth (position m e) e) (append (cdr m) (list i)))
(set! e (cons (list (nth i alist) i) e))) ))))

(define (subseq alist start stop)
(if (null? stop) (set! stop (length alist)))
(let ((res (list)))
 (do ((i start (+ i 1))) ((= i stop) (reverse res))
  (set! res (cons (nth i alist) res)))))

(define (segpos seq pos)
(let ((r (list)))
(do ((i 0 (+ i 1)))
((= i (length pos)) (reverse r))
(set! r (cons (subseq seq (nth i pos) (nth (+ i 1) pos)) r)))))

(define (segs seq)
(let ((r (list)) (p (apos seq)))
(do ((i 0 (+ i 1)))
((= i (length p)) (reverse r))
(set! r (cons (segpos seq (cdr (nth i p) )) r)))))

(define (mini alist)
(if (null? (cdr alist)) (car alist)
  (mini (if (< (car alist) (cadr alist))
    (cons (car alist) (cddr alist))
    (cons (cadr alist) (cddr alist))))))

(define (edist a b)
 (let ((couts (list 0)) (d 0) (d1 0) (d2 0) (d3 0) (c 0) (c1 0))
 (do ((j 0 (+ j 1))) ((= j (+ 1 (length b))))
  (do  ((i 0 (+ i 1))) ((= i (+ 1 (length a))))
  (set! d (+ i (* j (+ (length a) 1))))
  (if (and (> i 0) (> j 0))
   (begin
 (if (eq? (nth (- i 1) a) (nth (- j 1) b))
    (set! c1 0) (set! c1 1))
 (set! d1 (nth (+ (length a) 1) couts))
 (set! d2 (nth  (length a) couts))
 (set! d3 (car couts))
 (set! c  (mini (list (+ c1 d1) (+ 1 d2) (+ 1 d3))))
 (set! couts (cons c couts)))
  (begin
  (if (and (eq? i 0) (eq? j 0))
   (set! c1 0) (set! c1 1))
  (if (and (eq? i 0) (> j 0))
    (begin
    (set! d (nth (length a) couts))
    (set! c  (+ c1 d))
    (set! couts (cons c couts)))
  (if (and (> i 0) (eq? j 0))
    (begin (set! d (car couts))
     (set! c  (+ c1 d))
     (set! couts (cons c couts)))
     (begin
      (set! couts (cons 0 couts))
      (set! c 0))))))))
 (car couts)))

(define (pom a b seuil)
(if (<= (edist a b) seuil) t 'nil))

(define (mol a b seuil)
(pom a b seuil))

;(define (ac seq) ...

(la fonction principale « ac » reset réécrire en combinant « segs » et « edist »)

Exemples

(defvar seq '(a b a c a b e c a b a e c))

(apos seq)
; ((A 0 2 4 8 10) (B 1 5 9) (C 3 7 12) (E 6 11)

(segpos seq (cdar (apos seq)))
; ((A B) (A C) (A B E C) (A B) (A E C)

(mapcar (lambda (x) (append (cdr x) (segpos seq (cdr x)))) (apos seq))
; tout est la
; > combiner plus ou moins localement (car) avec :

(edist '(a b a c) '(a b e c))
; 1
(edist '(a b a c) '(a b e a c))
; 1
(edist '(a b a c) '(a b e c a))
; 2
(pom '(a b a c) '(a b e c) 1)
; T
(pom '(a b a c) '(a b e a c) 1)
; T

(flat (segs '(a b a c a b e c a b a e c)))

; (define (ac ...

; (ac '(a b a c a b e c a b a e c))

Voir en ligne : LispMe home page