Changeset 14345 in project


Ignore:
Timestamp:
04/22/09 15:01:17 (11 years ago)
Author:
Ivan Raikov
Message:

Adapted graph-dfs for Chicken 4.

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

Legend:

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

    r12066 r14345  
    99
    1010     (history
     11      (version "1.8" "Ported to Chicken 4")
    1112      (version "1.7" "Now using matchable extension")
    1213      (version "1.6" "Unit tests updated to use testbase")
     
    1920
    2021     (requires (url "iset.html" "iset")
    21                (url "syntax-case.html" "syntax-case")
    2222               (url "matchable.html" "matchable"))
    2323
  • release/4/graph-dfs/trunk/graph-dfs.meta

    r12066 r14345  
     1;;;; -*- Hen -*-
     2
    13((egg "graph-dfs.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-dfs.scm" "graph-dfs-eggdoc.scm" "graph-dfs.setup" "tests/run.scm")
     7 (files "graph-dfs.scm" "graph-dfs-eggdoc.scm" "graph-dfs.setup" "tests")
    68
    79 ; Your egg's license:
     
    1618 ; A list of eggs graph-dfs depends on.
    1719
    18  (needs testbase eggdoc iset syntax-case matchable)
     20 (needs test eggdoc iset matchable)
    1921
    2022 (eggdoc "graph-dfs-eggdoc.scm")
  • release/4/graph-dfs/trunk/graph-dfs.scm

    r12066 r14345  
    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)
    3025
    31 (define-extension graph-dfs)
     26(module graph-dfs
    3227
    33 (declare (export graph-dfs-foreach
    34                  graph-dfs-fold
    35                  graph-dfs-depth
    36                  graph-preorder
    37                  graph-postorder))
     28 (graph-dfs-foreach
     29  graph-dfs-fold
     30  graph-dfs-depth
     31  graph-preorder
     32  graph-postorder)
     33                   
     34 (import scheme chicken data-structures )
     35
     36 (require-extension srfi-1 srfi-4 iset matchable )
     37
    3838
    3939(define (graph-dfs:error x . rest)
     
    166166        (plst  (s32vector->list p)))
    167167    (filter-map (lambda (p i) (if (fx>= p 0) (list i p) #f)) plst is)))
     168)
  • release/4/graph-dfs/trunk/graph-dfs.setup

    r12066 r14345  
     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-dfs.exports) '())
    9          graph-dfs.scm -lchicken -ldl -lm)
     8(compile -O2 -d0 -s graph-dfs.scm -j graph-dfs)
     9(compile -O2 -d0 -s graph-dfs.import.scm)
    1010
    11 (run (csi -qbs graph-dfs-eggdoc.scm > graph-dfs.html))
     11(run (csi -s graph-dfs-eggdoc.scm > graph-dfs.html))
    1212
    1313(install-extension
     
    1717
    1818  ; Files to install for your extension:
    19   `(,(dynld-name "graph-dfs") "graph-dfs.html"
    20     ,@(if has-exports? '("graph-dfs.exports") (list)) )
     19  `(,(dynld-name "graph-dfs") ,(dynld-name "graph-dfs.import") )
    2120
    2221  ; Assoc list with properties for your extension:
    23   `((version 1.7)
     22  `((version 1.8)
    2423    (documentation "graph-dfs.html")
    25     ,@(if has-exports? `((exports "graph-dfs.exports")) (list)) ))
     24    ))
    2625
  • release/4/graph-dfs/trunk/tests/run.scm

    r6970 r14345  
    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-dfs)
    36 (require-extension testbase)
    37 (require-extension testbase-output-compact)
     29
     30(require-library srfi-1 srfi-13 digraph graph-dfs test)
     31(import srfi-1 srfi-13 digraph graph-dfs test)
    3832
    3933
     
    4943    (cons 'zag_o 'libzigzag_a) (cons 'libzigzag_a 'killerapp)))
    5044
     45   
     46(define node-list
     47  (delete-duplicates
     48   (concatenate (list (map car used-by) (map cdr used-by)))))
    5149
    52 (define-expect-unary pair?)
     50(define node-ids
     51  (list-tabulate (length node-list) values))
     52
     53(define node-map  (zip node-list node-ids))
    5354
    5455
    55 (define-test dfs-test "dfs 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)) )
     56(test-group "dfs test"
    6757
     58  (let ((g (make-digraph 'depgraph "dependency graph")))
    6859
    69   ;; can we make a graph
    70   (expect-set! g (make-digraph 'depgraph "dependency graph"))
     60    ;; add the nodes to the graph
     61    (for-each (lambda (i n) ((g 'add-node!) i n))
     62              node-ids node-list)
     63   
     64    ;; make sure all nodes got inserted
     65    (test "add nodes to the graph"
     66          ((g 'nodes))
     67          '((14 killerapp)
     68            (13 libzigzag_a) (12 zag_o) (11 zag_cpp)
     69            (10 zig_o) (9 zig_cpp) (8 libfoobar_a) (7 bar_o)
     70            (6 bar_cpp) (5 foo_o) (4 foo_cpp) (3 zow_h) (2 boz_h)
     71            (1 yow_h) (0 dax_h)))
    7172 
    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))
     73    ;; add the edges to the graph
     74    (for-each (lambda (e)
     75                (let* ((ni (car e))
     76                       (nj (cdr e))
     77                       (i (car (alist-ref ni node-map)))
     78                       (j (car (alist-ref nj node-map))))
     79                  ((g 'add-edge!) (list i j (format "~A->~A" ni nj)))))
     80              used-by)
    9881
    9982  ;; 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")))
     83  (test "added edges to the graph"
     84        ((g 'edges))
     85        '((13 14 "libzigzag_a->killerapp") (12 13 "zag_o->libzigzag_a")
     86          (11 12 "zag_cpp->zag_o") (10 13 "zig_o->libzigzag_a")
     87          (9 10 "zig_cpp->zig_o") (8 13 "libfoobar_a->libzigzag_a")
     88          (7 8 "bar_o->libfoobar_a") (6 7 "bar_cpp->bar_o")
     89          (5 8 "foo_o->libfoobar_a") (4 5 "foo_cpp->foo_o")
     90          (3 4 "zow_h->foo_cpp") (2 11 "boz_h->zag_cpp")
     91          (2 9 "boz_h->zig_cpp") (2 6 "boz_h->bar_cpp")
     92          (1 11 "yow_h->zag_cpp") (1 6 "yow_h->bar_cpp")
     93          (0 1 "dax_h->yow_h") (0 6 "dax_h->bar_cpp") (0 4 "dax_h->foo_cpp")))
    11194
    112   (test-eval 'get-roots ((g 'roots)))
     95  (let ((roots  ((g 'roots)))
     96        (str    (open-output-string)))
     97           
     98    (graph-dfs-foreach g
     99                       (lambda (n) (fprintf str "node ~A; " n))
     100                       (lambda (e) (fprintf str "edge ~A; " e))
     101                       roots)
    113102
    114   (test-let ((roots  ((g 'roots)))
    115              (str    (open-output-string)))
    116            
    117             (test-eval 'DFS-iterator
    118                        (graph-dfs-foreach g
    119                                           (lambda (n) (fprintf str "node ~A; " n))
    120                                           (lambda (e) (fprintf str "edge ~A; " e))
    121                                           roots))
     103    (test "DFS iteration"
     104          "node 3; edge (3 4 zow_h->foo_cpp); node 4; edge (4 5 foo_cpp->foo_o); node 5; edge (5 8 foo_o->libfoobar_a); node 8; edge (8 13 libfoobar_a->libzigzag_a); node 13; edge (13 14 libzigzag_a->killerapp); node 14; node 2; edge (2 11 boz_h->zag_cpp); node 11; edge (11 12 zag_cpp->zag_o); node 12; edge (2 9 boz_h->zig_cpp); node 9; edge (9 10 zig_cpp->zig_o); node 10; edge (2 6 boz_h->bar_cpp); node 6; edge (6 7 bar_cpp->bar_o); node 7; node 0; edge (0 1 dax_h->yow_h); node 1; "
     105          (get-output-string str))
     106   
     107   
     108    (test "DFS fold"
     109     (graph-dfs-fold g
     110                     (lambda (n ax) (cons (list 'node n) ax))
     111                     (lambda (e ax) (cons (list 'edge e) ax))
     112                     roots (list) (list))
     113     (values
     114      (reverse '((node 3) (node 4) (node 5) (node 8) (node 13) (node 14)
     115                 (node 2) (node 11) (node 12) (node 9) (node 10) (node 6)
     116                 (node 7) (node 0) (node 1)))
     117      (reverse '((edge (3 4 "zow_h->foo_cpp")) (edge (4 5 "foo_cpp->foo_o"))
     118                 (edge (5 8 "foo_o->libfoobar_a"))
     119                 (edge (8 13 "libfoobar_a->libzigzag_a"))
     120                 (edge (13 14 "libzigzag_a->killerapp"))
     121                 (edge (2 11 "boz_h->zag_cpp"))
     122                 (edge (11 12 "zag_cpp->zag_o")) (edge (2 9 "boz_h->zig_cpp"))
     123                 (edge (9 10 "zig_cpp->zig_o")) (edge (2 6 "boz_h->bar_cpp"))
     124                 (edge (6 7 "bar_cpp->bar_o")) (edge (0 1 "dax_h->yow_h")))))))
     125  ))
    122126
    123             (test/eq 'BFS-order #t
    124                      (string=?
    125                       (get-output-string str)
    126                       "node 3; edge (3 4 zow_h->foo_cpp); node 4; edge (4 5 foo_cpp->foo_o); node 5; edge (5 8 foo_o->libfoobar_a); node 8; edge (8 13 libfoobar_a->libzigzag_a); node 13; edge (13 14 libzigzag_a->killerapp); node 14; node 2; edge (2 11 boz_h->zag_cpp); node 11; edge (11 12 zag_cpp->zag_o); node 12; edge (2 9 boz_h->zig_cpp); node 9; edge (9 10 zig_cpp->zig_o); node 10; edge (2 6 boz_h->bar_cpp); node 6; edge (6 7 bar_cpp->bar_o); node 7; node 0; edge (0 1 dax_h->yow_h); node 1; "))
    127 
    128             (test/equal 'graph-bfs-fold
    129                         (graph-dfs-fold g
    130                                         (lambda (n ax) (cons (list 'node n) ax))
    131                                         (lambda (e ax) (cons (list 'edge e) ax))
    132                                         roots (list) (list))
    133                         (values
    134                          (reverse '((node 3) (node 4) (node 5) (node 8) (node 13) (node 14)
    135                                     (node 2) (node 11) (node 12) (node 9) (node 10) (node 6)
    136                                     (node 7) (node 0) (node 1)))
    137                          (reverse '((edge (3 4 "zow_h->foo_cpp")) (edge (4 5 "foo_cpp->foo_o"))
    138                                     (edge (5 8 "foo_o->libfoobar_a"))
    139                                     (edge (8 13 "libfoobar_a->libzigzag_a"))
    140                                     (edge (13 14 "libzigzag_a->killerapp"))
    141                                     (edge (2 11 "boz_h->zag_cpp"))
    142                                     (edge (11 12 "zag_cpp->zag_o")) (edge (2 9 "boz_h->zig_cpp"))
    143                                     (edge (9 10 "zig_cpp->zig_o")) (edge (2 6 "boz_h->bar_cpp"))
    144                                     (edge (6 7 "bar_cpp->bar_o")) (edge (0 1 "dax_h->yow_h")))))))
    145   )
    146 
    147 (test::styler-set! dfs-test test::output-style-compact)
    148 (run-test "dfs test")
Note: See TracChangeset for help on using the changeset viewer.