Work on data, threading and printing of threads
[kspaans/nntp-to-dot] / thread.ss
1 ;; Copyright (C) 2009  Kyle Spaans
2 ;;  this program is distributed under the GPL v2 or (at your option)
3 ;;  any later version.
4
5 ;; Detect and work with threads of messages in the newsgroup.
6 ;; Want to see:
7 ;; - number of unanswered messages
8 ;; - number of original posts versus replies
9 ;; - thread depths, average
10 ;; -
11
12 #lang scheme
13
14 (require "common.ss")
15 (require srfi/19)
16
17 (provide thread-print thread-hash)
18
19 (define refers (make-hash)) ;; map Message-IDs to node-IDs
20 (define threads '())        ;; list of structures representing each thread
21 (define post-count 0)       ;; total number of first-posts
22 (define reply-count 0)      ;; total number of reply messages
23
24 ;; Message Node Struct
25 ;;  Store newsgroup messages and reporoduce their threaded hierarchy in a
26 ;;  tree structure.
27 ;; string     - the user (From: header)
28 ;; string     - the Message-ID: of the message
29 ;; date       - date of the message
30 ;; string     - subject
31 ;; string     - node ID, used for dot ((make-node-id))
32 ;; list/mesgn - pointer to parent of this node, empty if no parent.
33 ;; list       - of mesgn, the children of this node
34 (define-struct mesgn (from id date subject node-id parent children) #:mutable #:transparent)
35
36 ;-------------------------
37 ;-------------------------
38 ;;; Want to put the message ID into the hash table with some kind of other unique ID
39 ;;; and then match references against the message ID to discover threads.
40 ;;; Directed edges will lead _away_ from the original post (towards follow-ups)
41 ;-------------------------
42 ;-------------------------
43
44 ;; look at head of the first few messages
45 (define (thread-print first last newsd)
46   (cond
47     [(= first last) (printf "****************\n")]
48     [else
49      (local
50        [(define mesg-from (message-getter
51                             newsd
52                             first
53                             (list from-regexp mid-regexp ref-regexp subj-regexp)))]
54        (if (boolean? mesg-from)
55            (void)
56            (map (lambda (x) (printf "~a~n" x)) mesg-from))
57        (newline))
58      (thread-print (+ first 1) last newsd)]))
59
60 ;; thread-post-process: void -> void
61 ;; do some work with the data collected by thread-hash, print to stdout:
62 ;; - number of "posts" number of "replies"
63 ;; - number of unanswered posts
64 (define (thread-post-process)
65   ;(for-each (lambda (n) (printf "~a~n" n)) threads)
66   (printf "Posts:   ~a~nReplies: ~a~n" post-count reply-count)
67   (printf "Size: ~a~n" (hash-count refers))
68   (printf "Threads: ~a~n" (length threads))
69   (printf "Heights: ~a~n" (map height threads))
70   (printf "TSizes:  ~a~n" (map num-children threads))
71   (newline)
72   ;(thread-pprint))
73   (thread-dot (cadddr (cddr threads))))
74
75 ;; thread-refs: (listof string) mesgn -> void
76 ;; Takes a list of references and a message node and creates the threading
77 ;; tree appropriately by looking up refs in the hash table. The last ref in
78 ;; the list should always be the appropriate one to use.
79 (define (thread-refs aloref mesgnode)
80    (let [(node-pair (hash-ref refers (last aloref) #f))]
81      (cond
82        [(boolean? node-pair) (printf "$$  Uh oh! Reference does not exist!~n")
83                              (printf "$$  ~a~n" (last aloref))
84                              (printf "$$  ~a~n~n" (mesgn-subject mesgnode))]
85         ;; Add to children of node it refers, and set mesg's parent
86        [else (printf "|--~a (~a) is a reply to ~a (~a)~n~n"
87                      (mesgn-node-id mesgnode)
88                      (mesgn-subject mesgnode)
89                      (mesgn-node-id (cadr node-pair))
90                      (mesgn-subject (cadr node-pair)))
91              (set-mesgn-children! (cadr node-pair)
92                             (cons mesgnode
93                                   (mesgn-children (cadr node-pair))))
94              (set-mesgn-parent! mesgnode (cadr node-pair))])))
95
96 ;; thread-pprint-internal: int mesgn -> void
97 ;; Does the work of thread-pprint, takes an argument for the threading
98 ;; depth.
99 (define (thread-pprint-internal depth mesgnode)
100   (cond
101     [(and (empty? (mesgn-children mesgnode)) (= 0 depth))
102      (printf "~a~n" (mesgn-subject mesgnode))]
103     [(empty? (mesgn-children mesgnode))
104      (printf "~a`--> ~a~n"
105              (make-string depth #\space)
106              (substring (mesgn-subject mesgnode) 9))]
107     [(= 0 depth) (printf "~a~n" (mesgn-subject mesgnode))
108                  (for-each
109                    (lambda (node)
110                      (thread-pprint-internal (add1 depth) node))
111                    (mesgn-children mesgnode))]
112     [else (printf "~a`--> ~a~n"
113                   (make-string depth #\space)
114                   (substring (mesgn-subject mesgnode) 9))
115           (for-each
116             (lambda (node)
117               (thread-pprint-internal (add1 depth) node))
118             (mesgn-children mesgnode))]))
119
120 ;; thread-pprint: void -> void
121 ;; Traverses the list "thread" and pretty prints threading.
122 (define (thread-pprint)
123   (for-each
124     (lambda (node)
125       (thread-pprint-internal 0 node))
126     threads))
127
128 ;; listmax: (listof nat) -> nat
129 ;; Finds the max in a list
130 (define (listmax lst)
131   (cond
132     [(empty? lst) 0]
133     [else (max (car lst) (listmax (cdr lst)))]))
134
135 ;; height: mesgn -> int
136 ;; Calculates the height of the thread
137 (define (height n)
138   (cond
139     [(empty? (mesgn-children n)) 1]
140     [else (add1 (listmax (map height (mesgn-children n))))]))
141
142 ;; num-children: mesgn -> int
143 ;; Calculates number of messages in thread
144 (define (num-children n)
145   (cond
146     [(empty? (mesgn-children n)) 1]
147     [else (foldr + 0 (map num-children (mesgn-children n)))]))
148
149 ;; thread-dot: mesgn -> void
150 ;; Takes a Message Node Struct and recursively prints out DOT code representing
151 ;; that tree. Prints to the given ioport.
152 ;; Also want easily-changable node-label options:
153 ;;   node-id, from, subj, date
154 (define node-label-format "~a [label=\"~a\\n~a\\n~a\"];")
155 (define (thread-dot mesgnode)
156   (local
157     [(define tdot (open-output-file "data/thread.dot" #:exists 'truncate))
158      (define (thread-dot-rec mesgnode)
159        (fprintf tdot
160                 node-label-format
161                 (mesgn-node-id mesgnode)
162                 ;; Remove '"' chars from the header
163                 (list->string
164                   (filter (lambda (c) (not (char=? #\" c)))
165                           (string->list (mesgn-from mesgnode))))
166                 (mesgn-subject mesgnode)
167                 (date->string (mesgn-date mesgnode) "~D"))
168        (for-each (lambda (n)
169                    (fprintf tdot
170                             "~a -> ~a\n"
171                             (mesgn-node-id mesgnode)
172                             (mesgn-node-id n)))
173                  (mesgn-children mesgnode))
174        (for-each thread-dot-rec (mesgn-children mesgnode)))]
175   (fprintf tdot "digraph cs136_threads {\n")
176   (thread-dot-rec mesgnode)
177   (fprintf tdot "// Run finished at: ~a\n}\n" (current-seconds))
178   (close-output-port tdot)))
179
180
181 ;; thread-hash: int int newsgroup ioport
182 ;; Reads messages from first to last in newsgroup newsd, printing
183 ;; info to stdout and to the file dotfile.
184 ;; Examines threading information, mostly in the "References:" header
185 ;; of each message, using a hash table "refers" to keep track of things.
186 ;; HASH TABLE:
187 ;;  Each message is given a unique node ID which is entered as a value in
188 ;;  the hash table, with the message-ID as the key. Paired with the node ID
189 ;;  is the Message Node Structure created for that message. This is so that
190 ;;  when references are found they can be added to the threading tree.
191 ;;  References are in the form of message-IDs, so the node ID that a
192 ;;  message refers to can be looked up.
193 (define (thread-hash first last newsd dotfile)
194   (cond
195     [(= first last) (thread-post-process)]
196     [else
197              ;; Order is: From, Subject, Date, MID, Refs
198      (local [(define message
199                (message-getter
200                   newsd
201                   first
202                   (list mid-regexp from-regexp date-regexp ref-regexp subj-regexp)))
203              (define mesg-from
204                (if (boolean? message) #f (car message)))
205              (define mesg-subj
206                (if (boolean? message) #f (cadr message)))
207              (define mesg-date
208                (if (boolean? message) #f (get-date (caddr message))))
209              (define mesg-mid
210                (if (boolean? message) #f (car (get-refs (cadddr message)))))
211              (define mesg-refs
212                (if (and (not (boolean? message)) (= 5 (length message)))
213                    (get-refs (cadr (cdddr message)))
214                    #f))
215              (define node-id (make-dot-id))]
216        (cond
217           ;; Message exists
218          [(not (boolean? message))
219           (let [(result (hash-ref refers mesg-mid #f))
220                 (mesgn-struct
221                   (make-mesgn mesg-from mesg-mid mesg-date mesg-subj node-id '() '()))]
222             (cond
223                ;; MID collision, should not happen.
224               [(string? result)
225                ;(printf "MIDs already in hash table?~n    >>~a<<~n" (caddr mesg-from))
226                (error `mid-collision)]
227                ;; No MID collision
228               [(boolean? result)
229                (fprintf dotfile "// Node ~a\n    ~a;\n" mesg-mid node-id)
230                (hash-set! refers mesg-mid (list node-id mesgn-struct))
231                (cond
232                   ;; Message has references
233                  [(= 5 (length message))
234                   (set! reply-count (add1 reply-count))
235                   (printf "|-Checking References to find threading...~n")
236                   (thread-refs mesg-refs mesgn-struct)]
237                   ;; Message does not have references
238                  [(= 4 (length message))
239                   (set! post-count (add1 post-count))
240                   (set! threads
241                         (cons mesgn-struct
242                               threads))])]))]
243          [else (printf "&&&&&&&& Whoops! Couldn't read message number ~a~n~n" first)]))
244      (thread-hash (+ first 1) last newsd dotfile)]))