Analyse contrastive en Scheme
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))