Commit | Line | Data |
---|---|---|
1b706edf LC |
1 | ; Modified 2 March 1997 by Will Clinger to add graphs-benchmark |
2 | ; and to expand the four macros below. | |
3 | ; Modified 11 June 1997 by Will Clinger to eliminate assertions | |
4 | ; and to replace a use of "recur" with a named let. | |
5 | ; | |
6 | ; Performance note: (graphs-benchmark 7) allocates | |
7 | ; 34509143 pairs | |
8 | ; 389625 vectors with 2551590 elements | |
9 | ; 56653504 closures (not counting top level and known procedures) | |
10 | ||
11 | (define (graphs-benchmark . rest) | |
12 | (let ((N (if (null? rest) 7 (car rest)))) | |
13 | (run-benchmark (string-append "graphs" (number->string N)) | |
14 | (lambda () | |
15 | (fold-over-rdg N | |
16 | 2 | |
17 | cons | |
18 | '()))))) | |
19 | ||
20 | ; End of new code. | |
21 | ||
22 | ;;; ==== std.ss ==== | |
23 | ||
24 | ; (define-syntax assert | |
25 | ; (syntax-rules () | |
26 | ; ((assert test info-rest ...) | |
27 | ; #F))) | |
28 | ; | |
29 | ; (define-syntax deny | |
30 | ; (syntax-rules () | |
31 | ; ((deny test info-rest ...) | |
32 | ; #F))) | |
33 | ; | |
34 | ; (define-syntax when | |
35 | ; (syntax-rules () | |
36 | ; ((when test e-first e-rest ...) | |
37 | ; (if test | |
38 | ; (begin e-first | |
39 | ; e-rest ...))))) | |
40 | ; | |
41 | ; (define-syntax unless | |
42 | ; (syntax-rules () | |
43 | ; ((unless test e-first e-rest ...) | |
44 | ; (if (not test) | |
45 | ; (begin e-first | |
46 | ; e-rest ...))))) | |
47 | ||
48 | (define assert | |
49 | (lambda (test . info) | |
50 | #f)) | |
51 | ||
52 | ;;; ==== util.ss ==== | |
53 | ||
54 | ||
55 | ; Fold over list elements, associating to the left. | |
56 | (define fold | |
57 | (lambda (lst folder state) | |
58 | '(assert (list? lst) | |
59 | lst) | |
60 | '(assert (procedure? folder) | |
61 | folder) | |
62 | (do ((lst lst | |
63 | (cdr lst)) | |
64 | (state state | |
65 | (folder (car lst) | |
66 | state))) | |
67 | ((null? lst) | |
68 | state)))) | |
69 | ||
70 | ; Given the size of a vector and a procedure which | |
71 | ; sends indicies to desired vector elements, create | |
72 | ; and return the vector. | |
73 | (define proc->vector | |
74 | (lambda (size f) | |
75 | '(assert (and (integer? size) | |
76 | (exact? size) | |
77 | (>= size 0)) | |
78 | size) | |
79 | '(assert (procedure? f) | |
80 | f) | |
81 | (if (zero? size) | |
82 | (vector) | |
83 | (let ((x (make-vector size (f 0)))) | |
84 | (let loop ((i 1)) | |
85 | (if (< i size) (begin ; [wdc - was when] | |
86 | (vector-set! x i (f i)) | |
87 | (loop (+ i 1))))) | |
88 | x)))) | |
89 | ||
90 | (define vector-fold | |
91 | (lambda (vec folder state) | |
92 | '(assert (vector? vec) | |
93 | vec) | |
94 | '(assert (procedure? folder) | |
95 | folder) | |
96 | (let ((len | |
97 | (vector-length vec))) | |
98 | (do ((i 0 | |
99 | (+ i 1)) | |
100 | (state state | |
101 | (folder (vector-ref vec i) | |
102 | state))) | |
103 | ((= i len) | |
104 | state))))) | |
105 | ||
106 | (define vector-map | |
107 | (lambda (vec proc) | |
108 | (proc->vector (vector-length vec) | |
109 | (lambda (i) | |
110 | (proc (vector-ref vec i)))))) | |
111 | ||
112 | ; Given limit, return the list 0, 1, ..., limit-1. | |
113 | (define giota | |
114 | (lambda (limit) | |
115 | '(assert (and (integer? limit) | |
116 | (exact? limit) | |
117 | (>= limit 0)) | |
118 | limit) | |
119 | (let -*- | |
120 | ((limit | |
121 | limit) | |
122 | (res | |
123 | '())) | |
124 | (if (zero? limit) | |
125 | res | |
126 | (let ((limit | |
127 | (- limit 1))) | |
128 | (-*- limit | |
129 | (cons limit res))))))) | |
130 | ||
131 | ; Fold over the integers [0, limit). | |
132 | (define gnatural-fold | |
133 | (lambda (limit folder state) | |
134 | '(assert (and (integer? limit) | |
135 | (exact? limit) | |
136 | (>= limit 0)) | |
137 | limit) | |
138 | '(assert (procedure? folder) | |
139 | folder) | |
140 | (do ((i 0 | |
141 | (+ i 1)) | |
142 | (state state | |
143 | (folder i state))) | |
144 | ((= i limit) | |
145 | state)))) | |
146 | ||
147 | ; Iterate over the integers [0, limit). | |
148 | (define gnatural-for-each | |
149 | (lambda (limit proc!) | |
150 | '(assert (and (integer? limit) | |
151 | (exact? limit) | |
152 | (>= limit 0)) | |
153 | limit) | |
154 | '(assert (procedure? proc!) | |
155 | proc!) | |
156 | (do ((i 0 | |
157 | (+ i 1))) | |
158 | ((= i limit)) | |
159 | (proc! i)))) | |
160 | ||
161 | (define natural-for-all? | |
162 | (lambda (limit ok?) | |
163 | '(assert (and (integer? limit) | |
164 | (exact? limit) | |
165 | (>= limit 0)) | |
166 | limit) | |
167 | '(assert (procedure? ok?) | |
168 | ok?) | |
169 | (let -*- | |
170 | ((i 0)) | |
171 | (or (= i limit) | |
172 | (and (ok? i) | |
173 | (-*- (+ i 1))))))) | |
174 | ||
175 | (define natural-there-exists? | |
176 | (lambda (limit ok?) | |
177 | '(assert (and (integer? limit) | |
178 | (exact? limit) | |
179 | (>= limit 0)) | |
180 | limit) | |
181 | '(assert (procedure? ok?) | |
182 | ok?) | |
183 | (let -*- | |
184 | ((i 0)) | |
185 | (and (not (= i limit)) | |
186 | (or (ok? i) | |
187 | (-*- (+ i 1))))))) | |
188 | ||
189 | (define there-exists? | |
190 | (lambda (lst ok?) | |
191 | '(assert (list? lst) | |
192 | lst) | |
193 | '(assert (procedure? ok?) | |
194 | ok?) | |
195 | (let -*- | |
196 | ((lst lst)) | |
197 | (and (not (null? lst)) | |
198 | (or (ok? (car lst)) | |
199 | (-*- (cdr lst))))))) | |
200 | ||
201 | ||
202 | ;;; ==== ptfold.ss ==== | |
203 | ||
204 | ||
205 | ; Fold over the tree of permutations of a universe. | |
206 | ; Each branch (from the root) is a permutation of universe. | |
207 | ; Each node at depth d corresponds to all permutations which pick the | |
208 | ; elements spelled out on the branch from the root to that node as | |
209 | ; the first d elements. | |
210 | ; Their are two components to the state: | |
211 | ; The b-state is only a function of the branch from the root. | |
212 | ; The t-state is a function of all nodes seen so far. | |
213 | ; At each node, b-folder is called via | |
214 | ; (b-folder elem b-state t-state deeper accross) | |
215 | ; where elem is the next element of the universe picked. | |
216 | ; If b-folder can determine the result of the total tree fold at this stage, | |
217 | ; it should simply return the result. | |
218 | ; If b-folder can determine the result of folding over the sub-tree | |
219 | ; rooted at the resulting node, it should call accross via | |
220 | ; (accross new-t-state) | |
221 | ; where new-t-state is that result. | |
222 | ; Otherwise, b-folder should call deeper via | |
223 | ; (deeper new-b-state new-t-state) | |
224 | ; where new-b-state is the b-state for the new node and new-t-state is | |
225 | ; the new folded t-state. | |
226 | ; At the leaves of the tree, t-folder is called via | |
227 | ; (t-folder b-state t-state accross) | |
228 | ; If t-folder can determine the result of the total tree fold at this stage, | |
229 | ; it should simply return that result. | |
230 | ; If not, it should call accross via | |
231 | ; (accross new-t-state) | |
232 | ; Note, fold-over-perm-tree always calls b-folder in depth-first order. | |
233 | ; I.e., when b-folder is called at depth d, the branch leading to that | |
234 | ; node is the most recent calls to b-folder at all the depths less than d. | |
235 | ; This is a gross efficiency hack so that b-folder can use mutation to | |
236 | ; keep the current branch. | |
237 | (define fold-over-perm-tree | |
238 | (lambda (universe b-folder b-state t-folder t-state) | |
239 | '(assert (list? universe) | |
240 | universe) | |
241 | '(assert (procedure? b-folder) | |
242 | b-folder) | |
243 | '(assert (procedure? t-folder) | |
244 | t-folder) | |
245 | (let -*- | |
246 | ((universe | |
247 | universe) | |
248 | (b-state | |
249 | b-state) | |
250 | (t-state | |
251 | t-state) | |
252 | (accross | |
253 | (lambda (final-t-state) | |
254 | final-t-state))) | |
255 | (if (null? universe) | |
256 | (t-folder b-state t-state accross) | |
257 | (let -**- | |
258 | ((in | |
259 | universe) | |
260 | (out | |
261 | '()) | |
262 | (t-state | |
263 | t-state)) | |
264 | (let* ((first | |
265 | (car in)) | |
266 | (rest | |
267 | (cdr in)) | |
268 | (accross | |
269 | (if (null? rest) | |
270 | accross | |
271 | (lambda (new-t-state) | |
272 | (-**- rest | |
273 | (cons first out) | |
274 | new-t-state))))) | |
275 | (b-folder first | |
276 | b-state | |
277 | t-state | |
278 | (lambda (new-b-state new-t-state) | |
279 | (-*- (fold out cons rest) | |
280 | new-b-state | |
281 | new-t-state | |
282 | accross)) | |
283 | accross))))))) | |
284 | ||
285 | ||
286 | ;;; ==== minimal.ss ==== | |
287 | ||
288 | ||
289 | ; A directed graph is stored as a connection matrix (vector-of-vectors) | |
290 | ; where the first index is the `from' vertex and the second is the `to' | |
291 | ; vertex. Each entry is a bool indicating if the edge exists. | |
292 | ; The diagonal of the matrix is never examined. | |
293 | ; Make-minimal? returns a procedure which tests if a labelling | |
294 | ; of the verticies is such that the matrix is minimal. | |
295 | ; If it is, then the procedure returns the result of folding over | |
296 | ; the elements of the automoriphism group. If not, it returns #F. | |
297 | ; The folding is done by calling folder via | |
298 | ; (folder perm state accross) | |
299 | ; If the folder wants to continue, it should call accross via | |
300 | ; (accross new-state) | |
301 | ; If it just wants the entire minimal? procedure to return something, | |
302 | ; it should return that. | |
303 | ; The ordering used is lexicographic (with #T > #F) and entries | |
304 | ; are examined in the following order: | |
305 | ; 1->0, 0->1 | |
306 | ; | |
307 | ; 2->0, 0->2 | |
308 | ; 2->1, 1->2 | |
309 | ; | |
310 | ; 3->0, 0->3 | |
311 | ; 3->1, 1->3 | |
312 | ; 3->2, 2->3 | |
313 | ; ... | |
314 | (define make-minimal? | |
315 | (lambda (max-size) | |
316 | '(assert (and (integer? max-size) | |
317 | (exact? max-size) | |
318 | (>= max-size 0)) | |
319 | max-size) | |
320 | (let ((iotas | |
321 | (proc->vector (+ max-size 1) | |
322 | giota)) | |
323 | (perm | |
324 | (make-vector max-size 0))) | |
325 | (lambda (size graph folder state) | |
326 | '(assert (and (integer? size) | |
327 | (exact? size) | |
328 | (<= 0 size max-size)) | |
329 | size | |
330 | max-size) | |
331 | '(assert (vector? graph) | |
332 | graph) | |
333 | '(assert (procedure? folder) | |
334 | folder) | |
335 | (fold-over-perm-tree (vector-ref iotas size) | |
336 | (lambda (perm-x x state deeper accross) | |
337 | (case (cmp-next-vertex graph perm x perm-x) | |
338 | ((less) | |
339 | #F) | |
340 | ((equal) | |
341 | (vector-set! perm x perm-x) | |
342 | (deeper (+ x 1) | |
343 | state)) | |
344 | ((more) | |
345 | (accross state)) | |
346 | (else | |
347 | (assert #F)))) | |
348 | 0 | |
349 | (lambda (leaf-depth state accross) | |
350 | '(assert (eqv? leaf-depth size) | |
351 | leaf-depth | |
352 | size) | |
353 | (folder perm state accross)) | |
354 | state))))) | |
355 | ||
356 | ; Given a graph, a partial permutation vector, the next input and the next | |
357 | ; output, return 'less, 'equal or 'more depending on the lexicographic | |
358 | ; comparison between the permuted and un-permuted graph. | |
359 | (define cmp-next-vertex | |
360 | (lambda (graph perm x perm-x) | |
361 | (let ((from-x | |
362 | (vector-ref graph x)) | |
363 | (from-perm-x | |
364 | (vector-ref graph perm-x))) | |
365 | (let -*- | |
366 | ((y | |
367 | 0)) | |
368 | (if (= x y) | |
369 | 'equal | |
370 | (let ((x->y? | |
371 | (vector-ref from-x y)) | |
372 | (perm-y | |
373 | (vector-ref perm y))) | |
374 | (cond ((eq? x->y? | |
375 | (vector-ref from-perm-x perm-y)) | |
376 | (let ((y->x? | |
377 | (vector-ref (vector-ref graph y) | |
378 | x))) | |
379 | (cond ((eq? y->x? | |
380 | (vector-ref (vector-ref graph perm-y) | |
381 | perm-x)) | |
382 | (-*- (+ y 1))) | |
383 | (y->x? | |
384 | 'less) | |
385 | (else | |
386 | 'more)))) | |
387 | (x->y? | |
388 | 'less) | |
389 | (else | |
390 | 'more)))))))) | |
391 | ||
392 | ||
393 | ;;; ==== rdg.ss ==== | |
394 | ||
395 | ||
396 | ; Fold over rooted directed graphs with bounded out-degree. | |
397 | ; Size is the number of verticies (including the root). Max-out is the | |
398 | ; maximum out-degree for any vertex. Folder is called via | |
399 | ; (folder edges state) | |
400 | ; where edges is a list of length size. The ith element of the list is | |
401 | ; a list of the verticies j for which there is an edge from i to j. | |
402 | ; The last vertex is the root. | |
403 | (define fold-over-rdg | |
404 | (lambda (size max-out folder state) | |
405 | '(assert (and (exact? size) | |
406 | (integer? size) | |
407 | (> size 0)) | |
408 | size) | |
409 | '(assert (and (exact? max-out) | |
410 | (integer? max-out) | |
411 | (>= max-out 0)) | |
412 | max-out) | |
413 | '(assert (procedure? folder) | |
414 | folder) | |
415 | (let* ((root | |
416 | (- size 1)) | |
417 | (edge? | |
418 | (proc->vector size | |
419 | (lambda (from) | |
420 | (make-vector size #F)))) | |
421 | (edges | |
422 | (make-vector size '())) | |
423 | (out-degrees | |
424 | (make-vector size 0)) | |
425 | (minimal-folder | |
426 | (make-minimal? root)) | |
427 | (non-root-minimal? | |
428 | (let ((cont | |
429 | (lambda (perm state accross) | |
430 | '(assert (eq? state #T) | |
431 | state) | |
432 | (accross #T)))) | |
433 | (lambda (size) | |
434 | (minimal-folder size | |
435 | edge? | |
436 | cont | |
437 | #T)))) | |
438 | (root-minimal? | |
439 | (let ((cont | |
440 | (lambda (perm state accross) | |
441 | '(assert (eq? state #T) | |
442 | state) | |
443 | (case (cmp-next-vertex edge? perm root root) | |
444 | ((less) | |
445 | #F) | |
446 | ((equal more) | |
447 | (accross #T)) | |
448 | (else | |
449 | (assert #F)))))) | |
450 | (lambda () | |
451 | (minimal-folder root | |
452 | edge? | |
453 | cont | |
454 | #T))))) | |
455 | (let -*- | |
456 | ((vertex | |
457 | 0) | |
458 | (state | |
459 | state)) | |
460 | (cond ((not (non-root-minimal? vertex)) | |
461 | state) | |
462 | ((= vertex root) | |
463 | '(assert | |
464 | (begin | |
465 | (gnatural-for-each root | |
466 | (lambda (v) | |
467 | '(assert (= (vector-ref out-degrees v) | |
468 | (length (vector-ref edges v))) | |
469 | v | |
470 | (vector-ref out-degrees v) | |
471 | (vector-ref edges v)))) | |
472 | #T)) | |
473 | (let ((reach? | |
474 | (make-reach? root edges)) | |
475 | (from-root | |
476 | (vector-ref edge? root))) | |
477 | (let -*- | |
478 | ((v | |
479 | 0) | |
480 | (outs | |
481 | 0) | |
482 | (efr | |
483 | '()) | |
484 | (efrr | |
485 | '()) | |
486 | (state | |
487 | state)) | |
488 | (cond ((not (or (= v root) | |
489 | (= outs max-out))) | |
490 | (vector-set! from-root v #T) | |
491 | (let ((state | |
492 | (-*- (+ v 1) | |
493 | (+ outs 1) | |
494 | (cons v efr) | |
495 | (cons (vector-ref reach? v) | |
496 | efrr) | |
497 | state))) | |
498 | (vector-set! from-root v #F) | |
499 | (-*- (+ v 1) | |
500 | outs | |
501 | efr | |
502 | efrr | |
503 | state))) | |
504 | ((and (natural-for-all? root | |
505 | (lambda (v) | |
506 | (there-exists? efrr | |
507 | (lambda (r) | |
508 | (vector-ref r v))))) | |
509 | (root-minimal?)) | |
510 | (vector-set! edges root efr) | |
511 | (folder | |
512 | (proc->vector size | |
513 | (lambda (i) | |
514 | (vector-ref edges i))) | |
515 | state)) | |
516 | (else | |
517 | state))))) | |
518 | (else | |
519 | (let ((from-vertex | |
520 | (vector-ref edge? vertex))) | |
521 | (let -**- | |
522 | ((sv | |
523 | 0) | |
524 | (outs | |
525 | 0) | |
526 | (state | |
527 | state)) | |
528 | (if (= sv vertex) | |
529 | (begin | |
530 | (vector-set! out-degrees vertex outs) | |
531 | (-*- (+ vertex 1) | |
532 | state)) | |
533 | (let* ((state | |
534 | ; no sv->vertex, no vertex->sv | |
535 | (-**- (+ sv 1) | |
536 | outs | |
537 | state)) | |
538 | (from-sv | |
539 | (vector-ref edge? sv)) | |
540 | (sv-out | |
541 | (vector-ref out-degrees sv)) | |
542 | (state | |
543 | (if (= sv-out max-out) | |
544 | state | |
545 | (begin | |
546 | (vector-set! edges | |
547 | sv | |
548 | (cons vertex | |
549 | (vector-ref edges sv))) | |
550 | (vector-set! from-sv vertex #T) | |
551 | (vector-set! out-degrees sv (+ sv-out 1)) | |
552 | (let* ((state | |
553 | ; sv->vertex, no vertex->sv | |
554 | (-**- (+ sv 1) | |
555 | outs | |
556 | state)) | |
557 | (state | |
558 | (if (= outs max-out) | |
559 | state | |
560 | (begin | |
561 | (vector-set! from-vertex sv #T) | |
562 | (vector-set! edges | |
563 | vertex | |
564 | (cons sv | |
565 | (vector-ref edges vertex))) | |
566 | (let ((state | |
567 | ; sv->vertex, vertex->sv | |
568 | (-**- (+ sv 1) | |
569 | (+ outs 1) | |
570 | state))) | |
571 | (vector-set! edges | |
572 | vertex | |
573 | (cdr (vector-ref edges vertex))) | |
574 | (vector-set! from-vertex sv #F) | |
575 | state))))) | |
576 | (vector-set! out-degrees sv sv-out) | |
577 | (vector-set! from-sv vertex #F) | |
578 | (vector-set! edges | |
579 | sv | |
580 | (cdr (vector-ref edges sv))) | |
581 | state))))) | |
582 | (if (= outs max-out) | |
583 | state | |
584 | (begin | |
585 | (vector-set! edges | |
586 | vertex | |
587 | (cons sv | |
588 | (vector-ref edges vertex))) | |
589 | (vector-set! from-vertex sv #T) | |
590 | (let ((state | |
591 | ; no sv->vertex, vertex->sv | |
592 | (-**- (+ sv 1) | |
593 | (+ outs 1) | |
594 | state))) | |
595 | (vector-set! from-vertex sv #F) | |
596 | (vector-set! edges | |
597 | vertex | |
598 | (cdr (vector-ref edges vertex))) | |
599 | state))))))))))))) | |
600 | ||
601 | ; Given a vector which maps vertex to out-going-edge list, | |
602 | ; return a vector which gives reachability. | |
603 | (define make-reach? | |
604 | (lambda (size vertex->out) | |
605 | (let ((res | |
606 | (proc->vector size | |
607 | (lambda (v) | |
608 | (let ((from-v | |
609 | (make-vector size #F))) | |
610 | (vector-set! from-v v #T) | |
611 | (for-each | |
612 | (lambda (x) | |
613 | (vector-set! from-v x #T)) | |
614 | (vector-ref vertex->out v)) | |
615 | from-v))))) | |
616 | (gnatural-for-each size | |
617 | (lambda (m) | |
618 | (let ((from-m | |
619 | (vector-ref res m))) | |
620 | (gnatural-for-each size | |
621 | (lambda (f) | |
622 | (let ((from-f | |
623 | (vector-ref res f))) | |
624 | (if (vector-ref from-f m); [wdc - was when] | |
625 | (begin | |
626 | (gnatural-for-each size | |
627 | (lambda (t) | |
628 | (if (vector-ref from-m t) | |
629 | (begin ; [wdc - was when] | |
630 | (vector-set! from-f t #T))))))))))))) | |
631 | res))) | |
632 | ||
633 | ||
634 | ;;; ==== test input ==== | |
635 | ||
636 | ; Produces all directed graphs with N verticies, distinguished root, | |
637 | ; and out-degree bounded by 2, upto isomorphism (there are 44). | |
638 | ||
639 | ;(define go | |
640 | ; (let ((N 7)) | |
641 | ; (fold-over-rdg N | |
642 | ; 2 | |
643 | ; cons | |
644 | ; '()))) |