lispdoc: implemented the whole URI syntax; updated URIs in all docstrings to be writt...
[com-informatimago:com-informatimago.git] / small-cl-pgms / author-signature.lisp
1 ;;;; -*- mode:lisp; coding:utf-8 -*-
2 ;;;;****************************************************************************
3 ;;;;FILE:               author-signature.lisp
4 ;;;;LANGUAGE:           Common-Lisp
5 ;;;;SYSTEM:             Common-Lisp
6 ;;;;USER-INTERFACE:     Common-Lisp
7 ;;;;DESCRIPTION
8 ;;;;    
9 ;;;;    This program compute an "author signature" from a text.
10 ;;;;    See: http://unix.dsu.edu/~johnsone/comp.html
11 ;;;;    
12 ;;;;AUTHORS
13 ;;;;    <PJB> Pascal Bourguignon
14 ;;;;MODIFICATIONS
15 ;;;;    2003-03-13 <PJB> Creation.
16 ;;;;BUGS
17 ;;;;LEGAL
18 ;;;;    AGPL3
19 ;;;;    
20 ;;;;    Copyright Pascal Bourguignon 2003 - 2012
21 ;;;;    
22 ;;;;    This program is free software: you can redistribute it and/or modify
23 ;;;;    it under the terms of the GNU Affero General Public License as published by
24 ;;;;    the Free Software Foundation, either version 3 of the License, or
25 ;;;;    (at your option) any later version.
26 ;;;;    
27 ;;;;    This program is distributed in the hope that it will be useful,
28 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
29 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
30 ;;;;    GNU Affero General Public License for more details.
31 ;;;;    
32 ;;;;    You should have received a copy of the GNU Affero General Public License
33 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>
34 ;;;;****************************************************************************
35
36
37 (defpackage "COM.INFORMATIMAGO.COMMON-LISP.AUTHOR-SIGNATURE"
38   (:documentation
39    "This program compute an \"author signature\" from a text.
40     See: <http://unix.dsu.edu/~johnsone/comp.html>
41     
42     Copyright Pascal Bourguignon 2003 - 2003
43     This package is provided under the GNU General Public License.
44     See the source file for details.")
45   (:use "COMMON-LISP")
46   (:export compare-texts tally-compare
47            tally-word-lengths tally-small-words
48            tally-percent  split-words )
49   );;COM.INFORMATIMAGO.COMMON-LISP.AUTHOR-SIGNATURE
50 (in-package "COM.INFORMATIMAGO.COMMON-LISP.AUTHOR-SIGNATURE")
51  
52
53 (defun stream-as-string (stream)
54   "
55 RETURN:  A string containing all the character read from the stream.
56 "
57   (loop with result = ""
58         with eoln = (format nil "~%")
59         for line = (read-line stream nil nil)
60         while line
61         do (setq result (concatenate 'string result line eoln))
62         finally (return result))
63   );;STREAM-AS-STRING
64
65
66 (defun remove-ponctuation (text)
67   "
68 RETURN: A copy of the text string where all character not alphanumeric is
69         replaced by a space.
70 "
71   (setq text (copy-seq text))
72   (loop for i from 0 below (length text)
73         for ch = (char text i)
74         do (unless (alphanumericp ch) (setf (char text i) #\SPACE)))
75   text
76   );;REMOVE-PONCTUATION
77
78
79 (defun split-words (text)
80   "
81 RETURN: A list of words read from the text.
82 "
83   (with-input-from-string
84    (in (remove-ponctuation text))
85    (let ((result  ())
86          (ch (read-char in nil nil)))
87      (loop while ch do
88            (loop while (and ch (eql #\SPACE ch)) ;;skip spaces
89                  do (setq ch (read-char in nil nil)))
90            (loop while (and ch (not (eql #\SPACE ch)))
91                  collect ch into word
92                  do (setq ch (read-char in nil nil))
93                  finally (when (< 0 (length word))
94                            (push (make-array (list (length word))
95                                              :element-type 'character
96                                              :initial-contents word) result)))
97            )
98      (nreverse result)))
99   ) ;;SPLIT-WORDS
100
101
102 (defun tally-word-lengths (word-list)
103   "
104 RETURN: An array containing the number of words of each length (in
105         slot 0 is stored the number of words greater than (length result),
106         and (length word-list).
107 "
108   ;; max word length in French: 36.
109   (let* ((max-len 36)
110          (tally (make-array (list (1+ max-len))
111                             :element-type 'fixnum
112                             :initial-element 0))
113          )
114     (loop for word in word-list
115           for len = (length word)
116           for count = 0 then (1+ count)
117           do
118           (if (< max-len len)
119             (incf (aref tally 0))
120             (incf (aref tally len)))
121           finally (return (values tally count))))
122   );;TALLY-WORD-LENGTHS
123
124
125 (defun tally-small-words (word-list)
126   "
127 RETURN: An array containing the number of occurences of a list of
128         small words returned as third value.
129         The second value is (length word-list).
130 "
131   (let* ((small-words '("A" "BUT" "IN" "NO" "OUR" "THE" "US"
132                         "WE" "WHICH" "WITH"))
133          (max-len (length small-words))
134          (tally (make-array (list (1+ max-len))
135                             :element-type 'fixnum
136                             :initial-element 0))
137          )
138     (loop for word in word-list
139           for count = 0 then (1+ count)
140           for pos = (position word small-words :test (function string-equal))
141           do
142           (if pos
143             (incf (aref tally (1+ pos)))
144             (incf (aref tally 0)))
145           finally (return (values tally count small-words))))
146   );;TALLY-SMALL-WORDS
147
148
149 ;; (TALLY-SMALL-WORDS (SPLIT-WORDS (WITH-OPEN-FILE (IN "~/tmp/misc/test.txt" :DIRECTION :INPUT) (STREAM-AS-STRING IN))))
150
151
152 (defun tally-percent (tally count)
153   (let ((result  (make-array (list (length tally))
154                              :element-type 'float
155                              :initial-element 0.0)))
156     (do ((i 0 (1+ i)))
157         ((<= (length tally) i) result)
158       (setf (aref result i) (coerce (/ (aref tally i) count) 'float))))
159   );;TALLY-PERCENT
160
161
162 (defun module (vector)
163   "
164 RETURN:  The module of the vector. [ sqrt(x^2+y^2+z^2) ]
165 "
166   (sqrt (apply (function +)
167                (map 'list (function (lambda (x) (* x x))) vector)))
168   );;MODULE
169
170
171 (defun tally-compare (tally-1 tally-2)
172   "
173 RETURN:  The module and the vector of percentages of differences
174          between vectors tally-1 and tally-2.
175 "
176   (assert (= (length tally-1) (length tally-2)))
177   (let ((differences (make-array (list (length tally-1))
178                                  :element-type 'float
179                                  :initial-element 0.0)))
180     (do* ((i 0 (1+ i))
181           (d) (m))
182         ((<= (length differences) i))
183       (setq d (abs (- (aref tally-1 i) (aref tally-2 i)))
184             m (max (aref tally-1 i) (aref tally-2 i)))
185       (setf (aref differences i) (if (= 0.0 m) m (coerce (/ d m) 'float))) )
186     (values (module differences) differences))
187   );;TALLY-COMPARE
188
189
190 (defun compare-texts (path-list tally-function)
191   (let ((tallies ()))
192     (mapc
193      (lambda (path)
194        (with-open-file (input path  :direction :input)
195          (push (cons (namestring path)
196                      (multiple-value-bind (tally c)
197                          (funcall tally-function 
198                           (split-words (stream-as-string input)))
199                        (tally-percent tally c))) tallies)))
200      path-list)
201     (do* ((t1 tallies (cdr t1))
202           (n-tally-1 (car t1) (car t1))
203           (tally-1 (cdr n-tally-1) (cdr n-tally-1)) )
204         ((null t1))
205   
206       (do* ((t2 (cdr t1) (cdr t2))
207             (n-tally-2 (car t2) (car t2))
208             (tally-2 (cdr n-tally-2) (cdr n-tally-2)) )
209           ((null t2))
210
211           (multiple-value-bind
212            (m d) (tally-compare tally-1 tally-2)
213            (format t "~20A ~20A ~8A~%   ~A~%~%"
214                    (car n-tally-1) (car n-tally-2) m d))
215         ))
216     tallies)
217   );;COMPARE-TEXTS
218
219
220 ;; (COMPARE-TEXTS (DIRECTORY "i-*.txt") (FUNCTION TALLY-WORD-LENGTHS))
221 ;; (COMPARE-TEXTS (DIRECTORY "i-*.txt") (FUNCTION TALLY-SMALL-WORDS))
222
223 ;; (TALLY-COMPARE
224 ;;  (MULTIPLE-VALUE-BIND (TALLY C)
225 ;;      (TALLY-WORD-LENGTHS (SPLIT-WORDS STR))
226 ;;    (TALLY-PERCENT TALLY C))
227 ;;  (MULTIPLE-VALUE-BIND (TALLY C)
228 ;;      (TALLY-WORD-LENGTHS (SPLIT-WORDS STR2))
229 ;;    (TALLY-PERCENT TALLY C)))
230
231
232
233 ;;;; author-signature.lisp            -- 2004-03-14 01:32:40 -- pascal   ;;;;