Changeset 14342 in project


Ignore:
Timestamp:
04/22/09 13:50:48 (11 years ago)
Author:
Ivan Raikov
Message:

graph-bfs ported to Chicken-4

Location:
release/4/graph-bfs/trunk
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • release/4/graph-bfs/trunk/graph-bfs-eggdoc.scm

    r12064 r14342  
    99
    1010     (history
     11      (version "1.9" "Ported to Chicken 4")
    1112      (version "1.8" "Now using matchable extension")
    1213      (version "1.7" "Unit tests updated to use testbase")
     
    2021
    2122     (requires (url "iset.html" "iset")
    22                (url "syntax-case.html" "syntax-case")
    2323               (url "matchable.html" "matchable"))
    2424
  • release/4/graph-bfs/trunk/graph-bfs.meta

    r12064 r14342  
     1;;;; -*- Hen -*-
     2
    13((egg "graph-bfs.egg") ; This should never change
    24
    35 ; List here all the files that should be bundled as part of your egg. 
    46
    5  (files "graph-bfs.scm" "graph-bfs-eggdoc.scm" "graph-bfs.setup" "tests/run.scm")
     7 (files "graph-bfs.scm" "graph-bfs-eggdoc.scm" "graph-bfs.setup" "tests")
    68
    79 ; Your egg's license:
     
    1618 ; A list of eggs graph-bfs depends on.
    1719
    18  (needs testbase eggdoc iset syntax-case matchable)
     20 (needs eggdoc iset matchable test)
    1921
    2022 (eggdoc "graph-bfs-eggdoc.scm")
  • release/4/graph-bfs/trunk/graph-bfs.scm

    r12064 r14342  
    55;;
    66;;
    7 ;; Copyright 2007 Ivan Raikov and the Okinawa Institute of Science and Technology
     7;; Copyright 2007-2009 Ivan Raikov and the Okinawa Institute of Science and Technology.
    88;;
    99;;
     
    2323;;
    2424
    25 (require-extension srfi-1)
    26 (require-extension srfi-4)
    27 (require-extension iset)
    28 (require-extension syntax-case)
    29 (require-extension matchable)
     25(module graph-bfs
    3026
    31 (define-extension graph-bfs)
     27 (graph-bfs-foreach
     28  graph-bfs-fold
     29  graph-bfs-dist)
     30                   
     31 (import scheme chicken data-structures )
    3232
    33 (declare (export graph-bfs-foreach
    34                  graph-bfs-fold
    35                  graph-bfs-dist))
     33 (require-extension srfi-1 srfi-4 iset matchable )
     34
    3635
    3736(define (graph-bfs:error x . rest)
     
    153152  (traverse-roots roots (list) (list))
    154153  (values d dmax))
     154)
  • release/4/graph-bfs/trunk/graph-bfs.setup

    r12064 r14342  
     1;;;; -*- Hen -*-
    12
    23(define has-exports? (string>=? (chicken-version) "2.310"))
     
    56  (make-pathname #f fn ##sys#load-dynamic-extension))   
    67
    7 (compile -O2 -d0 -s
    8          ,@(if has-exports? '(-check-imports -emit-exports graph-bfs.exports) '())
    9          graph-bfs.scm -lchicken -ldl -lm)
     8(compile -O2 -d0 -s graph-bfs.scm -j graph-bfs)
     9(compile -O2 -d0 -s graph-bfs.import.scm)
    1010
    11 (run (csi -qbs graph-bfs-eggdoc.scm > graph-bfs.html))
     11(run (csi -s graph-bfs-eggdoc.scm > graph-bfs.html))
    1212
    1313(install-extension
     
    1717
    1818  ; Files to install for your extension:
    19   `(,(dynld-name "graph-bfs") "graph-bfs.html"
    20     ,@(if has-exports? '("graph-bfs.exports") (list)) )
     19  `(,(dynld-name "graph-bfs") ,(dynld-name "graph-bfs.import") )
    2120
    2221  ; Assoc list with properties for your extension:
    23   `((version 1.8)
     22  `((version 1.9)
    2423    (documentation "graph-bfs.html")
    25     ,@(if has-exports? `((exports "graph-bfs.exports")) (list)) ))
     24    ))
    2625
  • release/4/graph-bfs/trunk/tests/run.scm

    r6968 r14342  
    44;; library dependency example.
    55;;
    6 ;; Version $Revision$
    7 ;;
    8 ;;
    9 ;; Copyright 2007 Ivan Raikov and the Okinawa Institute of Science and Technology
     6;; Copyright 2007-2009 Ivan Raikov and the Okinawa Institute of Science and Technology.
    107;;
    118;; This program is free software; you can redistribute it and/or
     
    3027;;
    3128
    32 (require-extension srfi-1)
    33 (require-extension srfi-13)
    34 (require-extension digraph)
    35 (require-extension graph-bfs)
    36 (require-extension testbase)
    37 (require-extension testbase-output-compact)
     29(require-library srfi-1 srfi-13 digraph graph-bfs test)
     30(import srfi-1 srfi-13 digraph graph-bfs test)
    3831
    3932
     
    4942    (cons 'zag_o 'libzigzag_a) (cons 'libzigzag_a 'killerapp)))
    5043
     44(define node-list
     45  (delete-duplicates
     46   (concatenate (list (map car used-by) (map cdr used-by)))))
    5147
    52 (define-expect-unary pair?)
     48(define node-ids
     49  (list-tabulate (length node-list) values))
     50
     51(define node-map  (zip node-list node-ids))
    5352
    5453
    55 (define-test bfs-test "bfs test"
    56   (initial
    57    (define g (void))
    58    
    59    (define node-list
    60      (delete-duplicates
    61       (concatenate (list (map car used-by) (map cdr used-by)))))
    62    
    63    (define node-ids
    64      (list-tabulate (length node-list) values))
    65    
    66    (define node-map  (zip node-list node-ids)) )
     54(test-group "BFS test"
     55
     56   (let ((g (make-digraph 'depgraph "dependency graph")))
     57 
     58     ;; add the nodes to the graph
     59     (for-each (lambda (i n) ((g 'add-node!) i n))
     60               node-ids node-list)
     61
     62     ;; make sure all nodes got inserted
     63     (test "add nodes to the graph"
     64           ((g 'nodes))
     65           '((14 killerapp)
     66             (13 libzigzag_a) (12 zag_o) (11 zag_cpp)
     67             (10 zig_o) (9 zig_cpp) (8 libfoobar_a) (7 bar_o)
     68             (6 bar_cpp) (5 foo_o) (4 foo_cpp) (3 zow_h) (2 boz_h)
     69             (1 yow_h) (0 dax_h)))
     70     
     71     ;; add the edges to the graph
     72     (for-each (lambda (e)
     73                 (let* ((ni (car e))
     74                        (nj (cdr e))
     75                        (i (car (alist-ref ni node-map)))
     76                        (j (car (alist-ref nj node-map))))
     77                   ((g 'add-edge!) (list i j (format "~A->~A" ni nj)))))
     78               used-by)
     79     
     80     ;; make sure all edges got correctly created
     81     (test "add edges to the graph"
     82           ((g 'edges))
     83           '((13 14 "libzigzag_a->killerapp") (12 13 "zag_o->libzigzag_a")
     84             (11 12 "zag_cpp->zag_o") (10 13 "zig_o->libzigzag_a")
     85             (9 10 "zig_cpp->zig_o") (8 13 "libfoobar_a->libzigzag_a")
     86             (7 8 "bar_o->libfoobar_a") (6 7 "bar_cpp->bar_o")
     87             (5 8 "foo_o->libfoobar_a") (4 5 "foo_cpp->foo_o")
     88             (3 4 "zow_h->foo_cpp") (2 11 "boz_h->zag_cpp")
     89             (2 9 "boz_h->zig_cpp") (2 6 "boz_h->bar_cpp")
     90             (1 11 "yow_h->zag_cpp") (1 6 "yow_h->bar_cpp")
     91             (0 1 "dax_h->yow_h") (0 6 "dax_h->bar_cpp") (0 4 "dax_h->foo_cpp")))
     92     
     93     (let ((roots  ((g 'roots)))
     94           (str    (open-output-string)))
     95       
     96       (graph-bfs-foreach g
     97                          (lambda (n) (fprintf str "node ~A; " n))
     98                          (lambda (e) (fprintf str "edge ~A; " e))
     99                          roots)
     100
     101    (test "BFS traversal"
     102         
     103          "node 3; node 2; node 0; node 3; edge (3 4 zow_h->foo_cpp); node 2; edge (2 11 boz_h->zag_cpp); edge (2 9 boz_h->zig_cpp); edge (2 6 boz_h->bar_cpp); node 0; edge (0 1 dax_h->yow_h); node 4; edge (4 5 foo_cpp->foo_o); node 11; edge (11 12 zag_cpp->zag_o); node 9; edge (9 10 zig_cpp->zig_o); node 6; edge (6 7 bar_cpp->bar_o); node 1; node 5; edge (5 8 foo_o->libfoobar_a); node 12; edge (12 13 zag_o->libzigzag_a); node 10; node 7; node 8; node 13; edge (13 14 libzigzag_a->killerapp); node 14; "
     104          (get-output-string str)
     105          )
     106   
     107    (test "BFS fold"
     108          (graph-bfs-fold g
     109                          (lambda (n ax) (cons (list 'node n) ax))
     110                          (lambda (e ax) (cons (list 'edge e) ax))
     111                          roots (list) (list))
     112          (values
     113           (reverse '((node 3) (node 2) (node 0) (node 4) (node 11)
     114                      (node 9) (node 6) (node 1) (node 5) (node 12)
     115                      (node 10) (node 7) (node 8) (node 13) (node 14)))
     116           (reverse '((edge (3 4 "zow_h->foo_cpp")) (edge (2 11 "boz_h->zag_cpp"))
     117                      (edge (2 9 "boz_h->zig_cpp")) (edge (2 6 "boz_h->bar_cpp"))
     118                      (edge (0 1 "dax_h->yow_h")) (edge (4 5 "foo_cpp->foo_o"))
     119                      (edge (11 12 "zag_cpp->zag_o")) (edge (9 10 "zig_cpp->zig_o"))
     120                      (edge (6 7 "bar_cpp->bar_o")) (edge (5 8 "foo_o->libfoobar_a"))
     121                      (edge (12 13 "zag_o->libzigzag_a")) (edge (13 14 "libzigzag_a->killerapp"))))))
     122    )))
    67123
    68124
    69   ;; can we make a graph
    70   (expect-set! g (make-digraph 'depgraph "dependency graph"))
    71  
    72   ;; add the nodes to the graph
    73   (test-eval 'add-nodes
    74              (for-each (lambda (i n) ((g 'add-node!) i n))
    75                        node-ids node-list))
    76 
    77   ;; make sure all nodes got inserted
    78   (test/equal 'nodes-inserted?
    79               ((g 'nodes))
    80               '((14 killerapp)
    81                 (13 libzigzag_a) (12 zag_o) (11 zag_cpp)
    82                 (10 zig_o) (9 zig_cpp) (8 libfoobar_a) (7 bar_o)
    83                 (6 bar_cpp) (5 foo_o) (4 foo_cpp) (3 zow_h) (2 boz_h)
    84                 (1 yow_h) (0 dax_h)))
    85  
    86   ;; add the edges to the graph
    87   (test/collect 'add-edges
    88                 (for-each (lambda (e)
    89                             (collect-test (expect-pair (conc "valid edge: " e) e))
    90                             (let* ((ni (car e))
    91                                    (nj (cdr e))
    92                                    (i (car (alist-ref ni node-map)))
    93                                    (j (car (alist-ref nj node-map))))
    94                               (collect-test
    95                                (expect-success "adding edge"
    96                                                ((g 'add-edge!) (list i j (format "~A->~A" ni nj))))) ) )
    97                           used-by))
    98 
    99   ;; make sure all edges got correctly created
    100   (test/equal 'edges-inserted?
    101               ((g 'edges))
    102               '((13 14 "libzigzag_a->killerapp") (12 13 "zag_o->libzigzag_a")
    103                 (11 12 "zag_cpp->zag_o") (10 13 "zig_o->libzigzag_a")
    104                 (9 10 "zig_cpp->zig_o") (8 13 "libfoobar_a->libzigzag_a")
    105                 (7 8 "bar_o->libfoobar_a") (6 7 "bar_cpp->bar_o")
    106                 (5 8 "foo_o->libfoobar_a") (4 5 "foo_cpp->foo_o")
    107                 (3 4 "zow_h->foo_cpp") (2 11 "boz_h->zag_cpp")
    108                 (2 9 "boz_h->zig_cpp") (2 6 "boz_h->bar_cpp")
    109                 (1 11 "yow_h->zag_cpp") (1 6 "yow_h->bar_cpp")
    110                 (0 1 "dax_h->yow_h") (0 6 "dax_h->bar_cpp") (0 4 "dax_h->foo_cpp")))
    111 
    112   (test-eval 'get-roots ((g 'roots)))
    113 
    114   (test-let ((roots  ((g 'roots)))
    115              (str    (open-output-string)))
    116 
    117 
    118             (test-eval 'BFS-iterator
    119                        (graph-bfs-foreach g
    120                                           (lambda (n) (fprintf str "node ~A; " n))
    121                                           (lambda (e) (fprintf str "edge ~A; " e))
    122                                           roots))
    123 
    124 
    125            
    126             (test/eq 'BFS-order #t
    127                      (string=?
    128                       (get-output-string str)
    129                       "node 3; node 2; node 0; node 3; edge (3 4 zow_h->foo_cpp); node 2; edge (2 11 boz_h->zag_cpp); edge (2 9 boz_h->zig_cpp); edge (2 6 boz_h->bar_cpp); node 0; edge (0 1 dax_h->yow_h); node 4; edge (4 5 foo_cpp->foo_o); node 11; edge (11 12 zag_cpp->zag_o); node 9; edge (9 10 zig_cpp->zig_o); node 6; edge (6 7 bar_cpp->bar_o); node 1; node 5; edge (5 8 foo_o->libfoobar_a); node 12; edge (12 13 zag_o->libzigzag_a); node 10; node 7; node 8; node 13; edge (13 14 libzigzag_a->killerapp); node 14; "))
    130  
    131            (test/equal 'graph-bfs-fold
    132                       (graph-bfs-fold g
    133                                       (lambda (n ax) (cons (list 'node n) ax))
    134                                       (lambda (e ax) (cons (list 'edge e) ax))
    135                                       roots (list) (list))
    136                       (values
    137                        (reverse '((node 3) (node 2) (node 0) (node 4) (node 11)
    138                                   (node 9) (node 6) (node 1) (node 5) (node 12)
    139                                   (node 10) (node 7) (node 8) (node 13) (node 14)))
    140                        (reverse '((edge (3 4 "zow_h->foo_cpp")) (edge (2 11 "boz_h->zag_cpp"))
    141                                   (edge (2 9 "boz_h->zig_cpp")) (edge (2 6 "boz_h->bar_cpp"))
    142                                   (edge (0 1 "dax_h->yow_h")) (edge (4 5 "foo_cpp->foo_o"))
    143                                   (edge (11 12 "zag_cpp->zag_o")) (edge (9 10 "zig_cpp->zig_o"))
    144                                   (edge (6 7 "bar_cpp->bar_o")) (edge (5 8 "foo_o->libfoobar_a"))
    145                                   (edge (12 13 "zag_o->libzigzag_a")) (edge (13 14 "libzigzag_a->killerapp"))))))
    146 
    147            ))
    148 
    149            
    150 (test::styler-set! bfs-test test::output-style-compact)
    151 (run-test "bfs test")
Note: See TracChangeset for help on using the changeset viewer.