ikarus/benchmarks/r6rs-benchmarks/graphs.ss

;;; GRAPHS -- Obtained from Andrew Wright.

(library (r6rs-benchmarks graphs)
  (export main)
  (import (r6rs) (r6rs-benchmarks))

   ;;; ==== util.ss ====

  
  ; Fold over list elements, associating to the left.
  (define fold
      (lambda (lst folder state)
  ;        (assert (list? lst)
  ;            lst)
  ;        (assert (procedure? folder)
  ;            folder)
          (do ((lst lst
                      (cdr lst))
                  (state state
                      (folder (car lst)
                          state)))
              ((null? lst)
                  state))))
  
  ; Given the size of a vector and a procedure which
  ; sends indicies to desired vector elements, create
  ; and return the vector.
  (define proc->vector
    (lambda (size f)
  ;    (assert (and (integer? size)
  ;                 (exact? size)
  ;                 (>= size 0))
  ;      size)
  ;    (assert (procedure? f)
  ;      f)
      (if (zero? size)
          (vector)
          (let ((x (make-vector size (f 0))))
            (let loop ((i 1))
              (if (< i size)
                (begin
                  (vector-set! x i (f i))
                  (loop (+ i 1)))))
            x))))
  
  (define vector-fold
      (lambda (vec folder state)
  ;        (assert (vector? vec)
  ;            vec)
  ;        (assert (procedure? folder)
  ;            folder)
          (let ((len
                      (vector-length vec)))
              (do ((i 0
                          (+ i 1))
                      (state state
                          (folder (vector-ref vec i)
                              state)))
                  ((= i len)
                      state)))))
  
  ; AZIZ: r6rs has vector-map, this is not even used
  ;(define vector-map
  ;    (lambda (vec proc)
  ;        (proc->vector (vector-length vec)
  ;            (lambda (i)
  ;                (proc (vector-ref vec i))))))
  
  ; Given limit, return the list 0, 1, ..., limit-1.
  (define giota
      (lambda (limit)
  ;        (assert (and (integer? limit)
  ;                (exact? limit)
  ;                (>= limit 0))
  ;            limit)
          (let _-*-
              ((limit
                      limit)
                  (res
                      '()))
              (if (zero? limit)
                  res
                  (let ((limit
                              (- limit 1)))
                      (_-*- limit
                          (cons limit res)))))))
  
  ; Fold over the integers [0, limit).
  (define gnatural-fold
      (lambda (limit folder state)
  ;        (assert (and (integer? limit)
  ;                (exact? limit)
  ;                (>= limit 0))
  ;            limit)
  ;        (assert (procedure? folder)
  ;            folder)
          (do ((i 0
                      (+ i 1))
                  (state state
                      (folder i state)))
              ((= i limit)
                  state))))
  
  ; Iterate over the integers [0, limit).
  (define gnatural-for-each
      (lambda (limit proc!)
  ;        (assert (and (integer? limit)
  ;                (exact? limit)
  ;                (>= limit 0))
  ;            limit)
  ;        (assert (procedure? proc!)
  ;            proc!)
          (do ((i 0
                      (+ i 1)))
              ((= i limit))
              (proc! i))))
  
  (define natural-for-all?
      (lambda (limit ok?)
  ;        (assert (and (integer? limit)
  ;                (exact? limit)
  ;                (>= limit 0))
  ;            limit)
  ;        (assert (procedure? ok?)
  ;            ok?)
          (let _-*-
              ((i 0))
              (or (= i limit)
                  (and (ok? i)
                      (_-*- (+ i 1)))))))
  
  (define natural-there-exists?
      (lambda (limit ok?)
  ;        (assert (and (integer? limit)
  ;                (exact? limit)
  ;                (>= limit 0))
  ;            limit)
  ;        (assert (procedure? ok?)
  ;            ok?)
          (let _-*-
              ((i 0))
              (and (not (= i limit))
                  (or (ok? i)
                      (_-*- (+ i 1)))))))
  
  (define there-exists?
      (lambda (lst ok?)
  ;        (assert (list? lst)
  ;            lst)
  ;        (assert (procedure? ok?)
  ;            ok?)
          (let _-*-
              ((lst lst))
              (and (not (null? lst))
                  (or (ok? (car lst))
                      (_-*- (cdr lst)))))))
  
  
  ;;; ==== ptfold.ss ====
  
  
  ; Fold over the tree of permutations of a universe.
  ; Each branch (from the root) is a permutation of universe.
  ; Each node at depth d corresponds to all permutations which pick the
  ; elements spelled out on the branch from the root to that node as
  ; the first d elements.
  ; Their are two components to the state:
  ;       The b-state is only a function of the branch from the root.
  ;       The t-state is a function of all nodes seen so far.
  ; At each node, b-folder is called via
  ;       (b-folder elem b-state t-state deeper accross)
  ; where elem is the next element of the universe picked.
  ; If b-folder can determine the result of the total tree fold at this stage,
  ; it should simply return the result.
  ; If b-folder can determine the result of folding over the sub-tree
  ; rooted at the resulting node, it should call accross via
  ;       (accross new-t-state)
  ; where new-t-state is that result.
  ; Otherwise, b-folder should call deeper via
  ;       (deeper new-b-state new-t-state)
  ; where new-b-state is the b-state for the new node and new-t-state is
  ; the new folded t-state.
  ; At the leaves of the tree, t-folder is called via
  ;       (t-folder b-state t-state accross)
  ; If t-folder can determine the result of the total tree fold at this stage,
  ; it should simply return that result.
  ; If not, it should call accross via
  ;       (accross new-t-state)
  ; Note, fold-over-perm-tree always calls b-folder in depth-first order.
  ; I.e., when b-folder is called at depth d, the branch leading to that
  ; node is the most recent calls to b-folder at all the depths less than d.
  ; This is a gross efficiency hack so that b-folder can use mutation to
  ; keep the current branch.
  (define fold-over-perm-tree
      (lambda (universe b-folder b-state t-folder t-state)
  ;        (assert (list? universe)
  ;            universe)
  ;        (assert (procedure? b-folder)
  ;            b-folder)
  ;        (assert (procedure? t-folder)
  ;            t-folder)
          (let _-*-
              ((universe
                      universe)
                  (b-state
                      b-state)
                  (t-state
                      t-state)
                  (accross
                      (lambda (final-t-state)
                          final-t-state)))
              (if (null? universe)
                  (t-folder b-state t-state accross)
                  (let _-**-
                      ((in
                              universe)
                          (out
                              '())
                          (t-state
                              t-state))
                      (let* ((first
                                  (car in))
                              (rest
                                  (cdr in))
                              (accross
                                  (if (null? rest)
                                      accross
                                      (lambda (new-t-state)
                                          (_-**- rest
                                              (cons first out)
                                              new-t-state)))))
                          (b-folder first
                              b-state
                              t-state
                              (lambda (new-b-state new-t-state)
                                  (_-*- (fold out cons rest)
                                      new-b-state
                                      new-t-state
                                      accross))
                              accross)))))))
  
  
  ;;; ==== minimal.ss ====
  
  
  ; A directed graph is stored as a connection matrix (vector-of-vectors)
  ; where the first index is the `from' vertex and the second is the `to'
  ; vertex.  Each entry is a bool indicating if the edge exists.
  ; The diagonal of the matrix is never examined.
  ; Make-minimal? returns a procedure which tests if a labelling
  ; of the verticies is such that the matrix is minimal.
  ; If it is, then the procedure returns the result of folding over
  ; the elements of the automoriphism group.  If not, it returns #f.
  ; The folding is done by calling folder via
  ;       (folder perm state accross)
  ; If the folder wants to continue, it should call accross via
  ;       (accross new-state)
  ; If it just wants the entire minimal? procedure to return something,
  ; it should return that.
  ; The ordering used is lexicographic (with #t > #f) and entries
  ; are examined in the following order:
  ;       1->0, 0->1
  ;
  ;       2->0, 0->2
  ;       2->1, 1->2
  ;
  ;       3->0, 0->3
  ;       3->1, 1->3
  ;       3->2, 2->3
  ;       ...
  (define make-minimal?
      (lambda (max-size)
  ;        (assert (and (integer? max-size)
  ;                (exact? max-size)
  ;                (>= max-size 0))
  ;            max-size)
          (let ((iotas
                      (proc->vector (+ max-size 1)
                          giota))
                  (perm
                      (make-vector max-size 0)))
              (lambda (size graph folder state)
  ;                (assert (and (integer? size)
  ;                        (exact? size)
  ;                        (<= 0 size max-size))
  ;                    size
  ;                    max-size)
  ;                (assert (vector? graph)
  ;                    graph)
  ;                (assert (procedure? folder)
  ;                    folder)
                  (fold-over-perm-tree (vector-ref iotas size)
                      (lambda (perm-x x state deeper accross)
                          (case (cmp-next-vertex graph perm x perm-x)
                              ((less)
                                  #f)
                              ((equal)
                                  (vector-set! perm x perm-x)
                                  (deeper (+ x 1)
                                      state))
                              ((more)
                                  (accross state))
                              (else
  ;                                (assert #f)
                                  (fatal-error "???"))))
                      0
                      (lambda (leaf-depth state accross)
  ;                        (assert (eqv? leaf-depth size)
  ;                            leaf-depth
  ;                            size)
                          (folder perm state accross))
                      state)))))
  
  ; Given a graph, a partial permutation vector, the next input and the next
  ; output, return 'less, 'equal or 'more depending on the lexicographic
  ; comparison between the permuted and un-permuted graph.
  (define cmp-next-vertex
      (lambda (graph perm x perm-x)
          (let ((from-x
                      (vector-ref graph x))
                  (from-perm-x
                      (vector-ref graph perm-x)))
              (let _-*-
                  ((y
                          0))
                  (if (= x y)
                      'equal
                      (let ((x->y?
                                  (vector-ref from-x y))
                              (perm-y
                                  (vector-ref perm y)))
                          (cond ((eq? x->y?
                                      (vector-ref from-perm-x perm-y))
                                  (let ((y->x?
                                              (vector-ref (vector-ref graph y)
                                                  x)))
                                      (cond ((eq? y->x?
                                                  (vector-ref (vector-ref graph perm-y)
                                                      perm-x))
                                              (_-*- (+ y 1)))
                                          (y->x?
                                              'less)
                                          (else
                                              'more))))
                              (x->y?
                                  'less)
                              (else
                                  'more))))))))
  
  
  ;;; ==== rdg.ss ====
  
  
  ; Fold over rooted directed graphs with bounded out-degree.
  ; Size is the number of verticies (including the root).  Max-out is the
  ; maximum out-degree for any vertex.  Folder is called via
  ;       (folder edges state)
  ; where edges is a list of length size.  The ith element of the list is
  ; a list of the verticies j for which there is an edge from i to j.
  ; The last vertex is the root.
  (define fold-over-rdg
      (lambda (size max-out folder state)
  ;        (assert (and (exact? size)
  ;                (integer? size)
  ;                (> size 0))
  ;            size)
  ;        (assert (and (exact? max-out)
  ;                (integer? max-out)
  ;                (>= max-out 0))
  ;            max-out)
  ;        (assert (procedure? folder)
  ;            folder)
          (let* ((root
                      (- size 1))
                  (edge?
                      (proc->vector size
                          (lambda (from)
                              (make-vector size #f))))
                  (edges
                      (make-vector size '()))
                  (out-degrees
                      (make-vector size 0))
                  (minimal-folder
                      (make-minimal? root))
                  (non-root-minimal?
                      (let ((cont
                                  (lambda (perm state accross)
  ;                                    (assert (eq? state #t)
  ;                                        state)
                                      (accross #t))))
                          (lambda (size)
                              (minimal-folder size
                                  edge?
                                  cont
                                  #t))))
                  (root-minimal?
                      (let ((cont
                                  (lambda (perm state accross)
  ;                                    (assert (eq? state #t)
  ;                                        state)
                                      (case (cmp-next-vertex edge? perm root root)
                                          ((less)
                                              #f)
                                          ((equal more)
                                              (accross #t))
                                          (else
  ;                                            (assert #f)
                                              (fatal-error "???"))))))
                          (lambda ()
                              (minimal-folder root
                                  edge?
                                  cont
                                  #t)))))
              (let _-*-
                  ((vertex
                          0)
                      (state
                          state))
                  (cond ((not (non-root-minimal? vertex))
                          state)
                      ((= vertex root)
  ;                        (assert
  ;                            (begin
  ;                                (gnatural-for-each root
  ;                                    (lambda (v)
  ;                                        (assert (= (vector-ref out-degrees v)
  ;                                                (length (vector-ref edges v)))
  ;                                            v
  ;                                            (vector-ref out-degrees v)
  ;                                            (vector-ref edges v))))
  ;                                #t))
                          (let ((reach?
                                      (make-reach? root edges))
                                  (from-root
                                      (vector-ref edge? root)))
                              (let _-*-
                                  ((v
                                          0)
                                      (outs
                                          0)
                                      (efr
                                          '())
                                      (efrr
                                          '())
                                      (state
                                          state))
                                  (cond ((not (or (= v root)
                                                  (= outs max-out)))
                                          (vector-set! from-root v #t)
                                          (let ((state
                                                      (_-*- (+ v 1)
                                                          (+ outs 1)
                                                          (cons v efr)
                                                          (cons (vector-ref reach? v)
                                                              efrr)
                                                          state)))
                                              (vector-set! from-root v #f)
                                              (_-*- (+ v 1)
                                                  outs
                                                  efr
                                                  efrr
                                                  state)))
                                      ((and (natural-for-all? root
                                                  (lambda (v)
                                                      (there-exists? efrr
                                                          (lambda (r)
                                                              (vector-ref r v)))))
                                              (root-minimal?))
                                          (vector-set! edges root efr)
                                          (folder
                                              (proc->vector size
                                                  (lambda (i)
                                                      (vector-ref edges i)))
                                              state))
                                      (else
                                          state)))))
                      (else
                          (let ((from-vertex
                                      (vector-ref edge? vertex)))
                              (let _-**-
                                  ((sv
                                          0)
                                      (outs
                                          0)
                                      (state
                                          state))
                                  (if (= sv vertex)
                                      (begin
                                          (vector-set! out-degrees vertex outs)
                                          (_-*- (+ vertex 1)
                                              state))
                                      (let* ((state
                                                  ; no sv->vertex, no vertex->sv
                                                  (_-**- (+ sv 1)
                                                      outs
                                                      state))
                                              (from-sv
                                                  (vector-ref edge? sv))
                                              (sv-out
                                                  (vector-ref out-degrees sv))
                                              (state
                                                  (if (= sv-out max-out)
                                                      state
                                                      (begin
                                                          (vector-set! edges
                                                              sv
                                                              (cons vertex
                                                                  (vector-ref edges sv)))
                                                          (vector-set! from-sv vertex #t)
                                                          (vector-set! out-degrees sv (+ sv-out 1))
                                                          (let* ((state
                                                                      ; sv->vertex, no vertex->sv
                                                                      (_-**- (+ sv 1)
                                                                          outs
                                                                          state))
                                                                  (state
                                                                      (if (= outs max-out)
                                                                          state
                                                                          (begin
                                                                              (vector-set! from-vertex sv #t)
                                                                              (vector-set! edges
                                                                                  vertex
                                                                                  (cons sv
                                                                                      (vector-ref edges vertex)))
                                                                              (let ((state
                                                                                          ; sv->vertex, vertex->sv
                                                                                          (_-**- (+ sv 1)
                                                                                              (+ outs 1)
                                                                                              state)))
                                                                                  (vector-set! edges
                                                                                      vertex
                                                                                      (cdr (vector-ref edges vertex)))
                                                                                  (vector-set! from-vertex sv #f)
                                                                                  state)))))
                                                              (vector-set! out-degrees sv sv-out)
                                                              (vector-set! from-sv vertex #f)
                                                              (vector-set! edges
                                                                  sv
                                                                  (cdr (vector-ref edges sv)))
                                                              state)))))
                                          (if (= outs max-out)
                                              state
                                              (begin
                                                  (vector-set! edges
                                                      vertex
                                                      (cons sv
                                                          (vector-ref edges vertex)))
                                                  (vector-set! from-vertex sv #t)
                                                  (let ((state
                                                              ; no sv->vertex, vertex->sv
                                                              (_-**- (+ sv 1)
                                                                  (+ outs 1)
                                                                  state)))
                                                      (vector-set! from-vertex sv #f)
                                                      (vector-set! edges
                                                          vertex
                                                          (cdr (vector-ref edges vertex)))
                                                      state)))))))))))))
  
  ; Given a vector which maps vertex to out-going-edge list,
  ; return a vector  which gives reachability.
  (define make-reach?
      (lambda (size vertex->out)
          (let ((res
                      (proc->vector size
                          (lambda (v)
                              (let ((from-v
                                          (make-vector size #f)))
                                  (vector-set! from-v v #t)
                                  (for-each
                                      (lambda (x)
                                          (vector-set! from-v x #t))
                                      (vector-ref vertex->out v))
                                  from-v)))))
              (gnatural-for-each size
                  (lambda (m)
                      (let ((from-m
                                  (vector-ref res m)))
                          (gnatural-for-each size
                              (lambda (f)
                                  (let ((from-f
                                              (vector-ref res f)))
                                      (if (vector-ref from-f m)
                                          (gnatural-for-each size
                                              (lambda (t)
                                                  (if (vector-ref from-m t)
                                                      (vector-set! from-f t #t)))))))))))
              res)))
  
  
  ;;; ==== test input ====
  
  ; Produces all directed graphs with N verticies, distinguished root,
  ; and out-degree bounded by 2, upto isomorphism.
  
  (define (run n)
    (fold-over-rdg n
      2 
      cons
      '()))
  
  (define (main)
    (run-benchmark
     "graphs"
     graphs-iters
     (lambda (result) (equal? (length result) 596))
     (lambda (n) (lambda () (run n)))
     5)))