gc-benchmarks/larceny/graphs.sch

   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 ;      '())))