Clavier Dvorak pour la langue française
Ergonomie du poste de travail informatique

Programme Common Lisp pour calculer
 les fréquences d'occurrence des 
caractères, digrammes et trigrammes dans un texte 

 Comments in English below

Tables des fréquences de caractère, digramme et trigramme dans un texte en langue française, établies à l'aide de ce programme

(in-package :CL-user)

;;;; Le calcul de la fréquence d'occurrence des caractères, digrammes et 
;;;; trigrammes dans un texte est réalisé par les deux fonctions 
;;;; principales suivantes:
;;;;
;;;; 1. la fonction Compter-Caractères fait le décompte des caractères, 
;;;; digrammes et trigrammes contenus dans un fichier dont le chemin d'accès
;;;; lui est donné en argument. Les décomptes sont stockés dans des tables de
;;;; hachage (tables associatives).
;;;;
;;;; 2. A partir des données du nombre d'occurrences stockées dans les tables,
;;;; la fonction Rapport-Des-Fréquences publie un rapport de fréquence dont le
;;;; contenu dépend de la valeur de ses arguments (clefs).
;;;; Par défaut le rapport est présenté dans la fenêtre d'interaction et:
;;;; - tous les types d'items sont publiés (caractères, digrammes et 
;;;;   trigrammes)
;;;; - les items sont triés selon leur fréquence
;;;; - le détail des voyelles accentuées apparaît
;;;; - les espaces, les chiffres et les retours à la ligne sont ignorés
;;;; - les digrammes et les trigrammes dont la fréquence est plus petite que 
;;;;   0.2% ne sont pas présentés.
;;;; 
;;;; Voir la fin de ce fichier pour des exemples d'utilisation
;;;;
;;;; REMARQUE
;;;; Ce programme est une adaptation française du programme original:
;;;; - la plupart des noms de fonctions et de variables ont été traduits en
;;;;   français, pour le reste voir le glossaire ci-dessous
;;;; - quelques commentaires ont été ajoutés pour le lecteur non averti.
;;;; L'objectif premier étant d'assurer un support à un cours d'introduction
;;;; à la programmation (en français).
;;;; 
;;;; Glossaire anglais-français
;;;; --------------------------
;;;; char : abréviation de character (caractère)
;;;; count : (dé)compte, compter
;;;; inc : abréviation de increment (incrémenter, incrément)
;;;; input : entrée
;;;; output : sortie
;;;; result : résultat
;;;; string : chaîne de caractères
;;;; tab : caractère tabulation
;;;; 
;;;;

;;;; ENGLISH
;;;; *******
;;;;
;;;; Functions to compute and report frequencies of characters, digrams and
;;;; trigrams from a text file
;;;;
;;;; There are 2 main functions:
;;;;
;;;; 1. Compter-Caractères (count-characters) : counts the occurrences of
;;;; characters, digrams and trigrams from a text file. The data are stored in
;;;; hashtables.
;;;; 2. Rapport-Des-Fréquences (report-frequencies) : from the data in the
;;;; hashtables, it reports the frequencies according to its arguments. Unless
;;;; specified otherwise, it:
;;;; - reports frequencies of characters, digrams and trigrams
;;;; - sorts items by frequency
;;;; - distinguishes accented vowels
;;;; - ignores spaces, digits and newlines
;;;; - doesn't publish items whose frequency is less than .2%
;;;;
;;;; Examples:
;;;;
;;;; counts the occurences in text.txt file
;;;; (compter-caractères #p"c:\\test.txt")
;;;;
;;;; reports the frequencies in the toploop window
;;;; (rapport-des-fréquences)
;;;;
;;;; doesn't report digrams and trigrams
;;;; sorts characters alphabetically
;;;; (rapport-des-fréquences :trier-freq? NIL :2g? NIL :3g? NIL)
;;;;
;;;; idem but doesn't distinguish accented vowels
;;;; (rapport-des-fréquences :trier-freq? NIL :accentuées? NIL :2g? NIL :3g? NIL)
;;;;
;;;; reports only digrams with 2 vowels
;;;;(rapport-des-fréquences 
;;;;   :caract? NIL 
;;;;   :3g? NIL
;;;;   :filtre-grammes (lambda (s) 
;;;;                     (every #'voyelle s)))
;;;;
;;;; reports only digrams with one E at least (accented or not)
;;;;(rapport-des-fréquences
;;;;   :caract? NIL 
;;;;   :3g? NIL
;;;;   :filtre-grammes (lambda (s) 
;;;;                     (find #\E s  ; items stored in uppercase
;;;;                           ;; voyelle returns the vowel without accent or NIL
;;;;                           :key (lambda (c) (or (voyelle c)
;;;;                                                c))))
;;;;
;;;;
;;;; Francis Leboutte - Juin 2002
;;;; f.leboutte @ algo.be
;;;;

;;;****************************************************************************
;;; Variables


;;; 3 tables de hachage pour stocker le décompte caractères, des digrammes
;;; et des trigrammes.
;;; Note: il n'est pas nécessaire d'initialiser le nombre d'entrées d'une
;;; table de hachage.
;;;
;;; entrée : la clef d'accès est le caractère (majuscule), la valeur est le
;;; nombre d'occurences
(defvar *caractères* (make-hash-table))

;;; entrée : la clef d'accès est le digramme (string, majuscule), la valeur est
;;; le nombre d'occurences
(defvar *digrammes* (make-hash-table :test #'equal))

;;; entrée : la clef d'accès est le digramme (string, majuscule), la valeur est
;;; le nombre d'occurences
(defvar *trigrammes* (make-hash-table :test #'equal))

;;; pour conserver le chemin d'accès du Fichier à Analyser
(defvar *chemin-FA* NIL)


;;;****************************************************************************

;;; La fonction compter-caractères fait le décompte des caractères, des
;;; digrammes et des trigrammes contenus dans un fichier dont le chemin d'accès
;;; lui est donné en argument. Les décomptes sont stockés dans des tables de
;;; hachage.
;;; Chemin : chemin d'accès du fichier à analyser (pathname)
;;; NB des espaces (#\space) consécutifs sont comptés pour un seul espace
(defun compter-caractères (chemin
                           &optional
                           ;; par défaut les tabs (caractère tabulation) ne
                           ;; sont pas comptés
                           (tab? NIL))
  ;; remise à zéro des tables
  (clrhash *caractères*)
  (clrhash *digrammes*)
  (clrhash *trigrammes*)
  (unless (and (or (stringp chemin) (pathnamep chemin))
               (probe-file chemin))
    (error "Il n'existe pas de fichier correspondant au chemin d'accès~%~A"
      chemin))
  (setf *chemin-FA* chemin)
  (let (;; pour le décompte des espaces consécutifs (pour information)
        (espaces-non-comptés 0))
    ;; ouverture d'un flot (Stream) sur le fichier (Path). Note : le flot est
    ;; fermé automatiquement dès la sortie de la forme (with-open-file ...)
    (with-open-file (stream chemin :direction :input)
      (loop                                               ; boucle
        with caract-précédent and c1 and c2 and c3
        ;; lecture d'un caractère  - eof : End Of File
        as char = (read-char stream NIL :eof)
        while (not (eq char :eof))
        do
        (cond ((char= char #\space)
               (setf c1 NIL c2 NIL c3 NIL)
               (if (char= #\space caract-précédent)
                   (incf espaces-non-comptés)
                 (inc-char-count #\space)))
              ((char= #\tab char)
               (setf c1 NIL c2 NIL c3 NIL)
               (when tab?
                 (inc-char-count #\tab)))
              ((char= #\newline char)
               (setf c1 NIL c2 NIL c3 NIL)
               (inc-char-count #\newline))
              (T 
               (inc-char-count char)
               (setf c3 char)
               (when c2
                 (inc-grammes c1 c2 c3))
               (setf c1 c2 c2 c3)))
        (setf caract-précédent char)))
    (format t "~% espaces non comptés : ~D" espaces-non-comptés)
    ))


;;; A partir des données du nombre d'occurrences stockées dans les tables,
;;; la fonction Rapport-Des-Fréquences publie un rapport de fréquence dont le
;;; contenu dépend de la valeur des arguments (clefs).
;;; Par défaut le rapport est présenté dans la fenêtre d'interaction et:
;;; - tous les types d'items sont publiés (caractères, digrammes et trigrammes)
;;; - les items sont triés selon leur fréquence
;;; - le détail des voyelles accentuées apparaît
;;; - les espaces, les chiffres et les retours à la ligne sont ignorés
;;; - les digrammes et les trigrammes dont la fréquence est plus petite que 0.2%
;;;   ne sont pas présentés
(defun rapport-des-fréquences (&key
                               ;; où sortir le rapport : 
                               ;; - soit dans la fenêtre d'interaction (T), le défaut
                               ;; - soit dans un fichier (pathname designator)
                               (chemin T)
                               ;; T : tri selon la fréquence, sinon tri alphabétique
                               (trier-freq? T)
                               ;; T : fait le détail des voyelles accentuées
                               (accentuées? T)
                               ;; NIL : les espaces et tabs n'interviennent pas
                               ;;       dans le décompte
                               (espaces? NIL)
                               ;; NIL : les chiffres n'interviennent pas
                               (chiffres? NIL)
                               ;; NIL : les retours à la ligne n'interviennent pas
                               (retours? NIL)
                               ;; % , seuil de fréq à partir duquel un n-gramme est
                               ;; présenté dans le rapport
                               (seuil-de-fréq .2)
                               (nbre-décimales 2)
                               ;; présente les caractères ou non
                               (caract? T)
                               ;; présente les digrammes ou non
                               (2g? T)
                               ;; présente les trigrammes ou non
                               (3g? T)
                               ;; fonction d'un argument (un di ou un trigramme) pour
                               ;; ne publier que certains des digrammes (trigrammes)
                               ;; Voir les exemples d'utilisation (fin du fichier)
                               filtre-grammes)
  ;; définition de 3 fonctions locales
  (labels ((intervient? (caract)
              (and (or chiffres?
                       (not (digit-char-p caract)))
                   (or espaces?
                       (not (member caract '(#\tab #\space))))
                   (or retours?
                       (not (char= caract #\newline)))))
           (format-ligne (stream caract count total)
              (format stream "~&~A~C~A~C~,vF" 
                (nom-caract caract)
                #\tab count #\tab 
                nbre-décimales
                (float (* 100 (/ count total)))))
           (rapport-des-fréquences-aux (stream)
              (let ((total 0)
                    (result nil))
                (format stream "~&Analyse du fichier ~A~2%" *chemin-FA*)
                (when caract?
                  (maphash (lambda (k v)    ; Key (caract) - Value (décompte)
                             (when (intervient? k)
                               (let (voyelle)
                                 (cond (accentuées? 
                                        (push (cons k v) result))
                                       ((setf voyelle (voyelle k))
                                        (let ((dp (assoc voyelle result)))
                                          (if dp
                                              (incf (cdr dp) v)
                                            (push (cons voyelle v) result))))
                                       (T (push (cons k v) result))))
                               (incf total v)))
                           *caractères*)
                  (format stream "~&~D occurences de caractères:~2%" total)
                  (setf result
                    (if trier-freq?
                        (sort result #'>= :key #'cdr)
                      (sort result 
                            ;; tri alphabétique: il ne suffit pas d'utiliser le
                            ;; prédicat char< , car il faut que les voyelles accentuées
                            ;; tombent en bonne place ...
                            (lambda (caract-majuscule1 caract-majuscule2)
                              (let ((voy1 (voyelle caract-majuscule1))
                                    (voy2 (voyelle caract-majuscule2)))
                                (if (and voy1 voy2 (char= voy1 voy2))
                                    (char< caract-majuscule1 caract-majuscule2)
                                  (char< (if voy1 voy1 caract-majuscule1)
                                         (if voy2 voy2 caract-majuscule2)))))
                            :key #'car)))
                  (mapc (lambda (dp)
                          (let ((caract (car dp))
                                (count (cdr dp)))
                            (when (intervient? caract)
                              (format-ligne stream caract count total))))
                    result))
                (rapport-des-di-et-trigrammes stream 
                   :seuil-de-fréq seuil-de-fréq
                   :nbre-décimales nbre-décimales
                   :filtre-grammes filtre-grammes
                   :2g? 2g?
                   :3g? 3g?))))
    ;; corps principal
    (if (eq t chemin)
        (rapport-des-fréquences-aux T)
      (with-open-file (stream chemin :direction :output
                         :if-does-not-exist :create
                         :if-exists :overwrite)
        (rapport-des-fréquences-aux stream)))
    (values)))


(defun rapport-des-di-et-trigrammes (stream
                                     &key
                                     (seuil-de-fréq .2)
                                     (nbre-décimales 2)
                                     filtre-grammes
                                     (2g? T)
                                     (3g? T))
  (flet ((rapport-table (table-h)
            (let ((total-occurrences 0) 
                  (nbre-n-grammes 0)            ; nbre-n-grammes différents
                  (result NIL)
                  (gram-length (block :n (maphash (lambda (k v)
                                                    (declare (ignore v))
                                                    (return-from :n (length k)))
                                                  table-h))))
              (maphash (lambda (k v)
                         (incf nbre-n-grammes)
                         (push (cons k v) result)
                         (incf total-occurrences v))
                       table-h)
              (setf result (sort result #'>= :key #'cdr))
              (format stream "~2%~D ~A différents (~D occurences):~2%" 
                nbre-n-grammes
                (if (= gram-length 2) "digrammes" "trigrammes")
                total-occurrences)
              (block :report
               (mapc (lambda (dp)
                       (let* ((k (car dp))
                              (count (cdr dp))
                              (percent (float (* 100 (/ count total-occurrences)))))
                         (cond ((< percent seuil-de-fréq)
                                (return-from :report))
                               ((or (not filtre-grammes)
                                    (funcall filtre-grammes k))
                                (format stream "~&~A~C~A~C~,vF" 
                                  k  #\tab count #\tab 
                                  nbre-décimales percent))
                               (T NIL))))
                 result)))))
    (when 2g? (rapport-table *digrammes*))
    (when 3g? (rapport-table *trigrammes*))
    (values)))


;;; incrémente les décomptes dans les tables *digrammes* et *trigrammes*
;;; selon les arguments
(defun inc-grammes (c1 c2 c3)
  (declare (optimize (speed 3) (safety 1) (debug 0) (space 0)))
  ;; définition d'une macro locale
  (macrolet ((char-up (char)                    ; caractère en majuscule
                `(when (alpha-char-p ,char)
                   (setf ,char (char-upcase ,char)))))
    ;; définition d'une fonction locale
    (flet ((inc-grammes-aux (n-gramme table-h)
              (let ((value (gethash n-gramme table-h)))
                (cond (value 
                       (setf (gethash n-gramme table-h) (1+ value)))
                      ;; le di(tri)gramme doit être copié car la fonction
                      ;; make-string+ ne crée pas de nouvelle chaîne de
                      ;; caractères
                      (T (setf (gethash (copy-seq n-gramme) table-h) 1))))))
      (char-up c2)
      (char-up c3)
      (inc-grammes-aux (make-string+ 2 c2 c3) *digrammes*)
      (when c1
        (char-up c1)
        (inc-grammes-aux (make-string+ 3 c1 c2 c3) *trigrammes*))
      )))


;;; Retourne une chaîne de caractères de longueur Size contenant les
;;; caractères Chars (qui doivent être au nombre de Size)
;;; NB ne crée pas de nouvelle chaîne de caractères
(defun make-string+ (size &rest chars)
  ;; declaration pour le compilateur (optimisation de la vitesse d'exécution)
  (declare (optimize (speed 3) (safety 1) (debug 0) (space 0)))
  ;; load-time-value : optimisation, S2 (S3) est associés à un objet littéral
  ;; (literal object) dans le code compilé (une chaîne de caractères de
  ;; longueur 2 - string). On évite ainsi la reconstruction du string à chaque
  ;; appel de la fonction make-string+
  (let* ((s2 (load-time-value (make-string 2)))
         (s3 (load-time-value (make-string 3)))
         (s (if (= size 2) s2 s3)))
    (loop for char in chars
          as i = 0 then (1+ i)
          do
          (setf (char s i) char))
    s))


(defun inc-char-count (char)
  (when (alpha-char-p  char)
    (setf char (char-upcase char)))
  (let ((value (gethash char *caractères*)))
    (cond (value
           (setf (gethash char *caractères*) (1+ value)))
          (T (setf (gethash char *caractères*) 1)))))
          

;;; si c'est une voyelle accentuée retourne la même voyelle sans accent (majuscule)
;;;  sinon si c'est une voyelle sans accent retourne la voyelle (majuscule)
;;;  sinon (ce n'est pas une voyelle) retourne NIL
;;; Function pouvant servir au français et au néerlandais au moins
(defun voyelle (caract-majuscule)
  (case caract-majuscule
    ((#\E #\É #\È #\Ê #\Ë) #\E)
    ((#\I #\Î #\Ï) #\I)
    ((#\U #\Ù #\Û #\Ü) #\U)
    ((#\A #\À #\Â #\Ä) #\A)
    ((#\O #\Ô #\Ö) #\O)
    (T NIL)))

(defun nom-caract (caract)
  (case caract
    (#\tab "tab")
    (#\space "espa")
    (#\. "pt")
    (#\, "virg")
    (#\; "pt-v")
    (#\' "apos")
    (#\" "guil")
    (#\newline "ret")
    (#\` "bkq")  ;  Accent grave isolé ou 'backquote' - pas en français
    (T (if (alphanumericp caract)
           caract
         (let ((nom (char-name caract)))
           (if nom
               nom
             caract))))))

;;;****************************************************************************

#|

Exemples d'utilisation
----------------------

;;; analyse (comptage) du fichier c:\mes documents\test.txt
(compter-caractères #p"c:\\mes documents\\test.txt")

;;; publication des résultats dans la fenêtre d'interaction
(rapport-des-fréquences)

;;; publication dans le fichier c:\mes documents\rapport-test.txt
(rapport-des-fréquences :chemin #p"c:\\mes documents\\rapport-test.txt")

;;; publie uniquement les caractères (pas les digrammes, ni les trigrammes), 
;;; triés alphabétiquement
(rapport-des-fréquences :trier-freq? NIL :2g? NIL :3g? NIL)

;;; même chose mais une voyelle accentuée est comptée sous la voyelle 
;;; sans l'accent
(rapport-des-fréquences :trier-freq? NIL :accentuées? NIL :2g? NIL :3g? NIL)

;;; publie uniquement les digrammes à 2 voyelles
(rapport-des-fréquences 
   :caract? NIL 
   :3g? NIL
   :filtre-grammes (lambda (s) 
                     (every #'voyelle s)))

;;; publie uniquement les digrammes comportant au moins un E (accentué ou non)
(rapport-des-fréquences
   :caract? NIL 
   :3g? NIL
   :filtre-grammes (lambda (s)
                         (find #\E s  ; #\E et pas #\e car stockage majuscule
                           ;; voyelle retourne la voyelle sans accent ou NIL
                           :key (lambda (c) (or (voyelle c)
                                                c)))))
|#



Aller en haut de la page
   www.algo.be   Francis Leboutte   +32(0)4.388.39.19