Changeset 14362 in project


Ignore:
Timestamp:
04/23/09 01:59:42 (11 years ago)
Author:
Ivan Raikov
Message:

Ported graph-scc to Chicken 4

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

Legend:

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

    r12056 r14362  
    66     (name "graph-scc")
    77     (description "Compute strongly-connected components (SCC) of a graph.")
    8      (author (url "http://chicken.wiki.br/ivan raikov" "Ivan Raikov"))
     8     (author (url "http://chicken.wiki.br/users/ivan-raikov" "Ivan Raikov"))
    99
    1010     (history
     11      (version "1.8" "Ported to Chicken 4")
    1112      (version "1.7" "Now using matchable extension")
    1213      (version "1.6" "Updated meta file for testbase")
     
    1920
    2021     (requires (url "iset.html" "iset")
    21                (url "syntax-case.html" "syntax-case")
    2222               (url "matchable.html" "matchable"))
    2323
  • release/4/graph-scc/trunk/graph-scc.meta

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

    r12055 r14362  
    66;; Based on code from MLRISC
    77;;
    8 ;; Copyright 2007 Ivan Raikov and the Okinawa Institute of Science and Technology
     8;; Copyright 2007-2009 Ivan Raikov and the Okinawa Institute of Science and Technology.
    99;;
    1010;;
     
    2323;;
    2424
    25 (require-extension srfi-1)
    26 (require-extension srfi-4)
    27 (require-extension iset)
    28 (require-extension extras)
    29 (require-extension syntax-case)
    30 (require-extension matchable)
    3125
    32 (define-extension graph-scc)
     26(module graph-scc
    3327
    34 (declare (export graph-scc-fold))
     28 (graph-scc-fold)
     29                   
     30 (import scheme chicken data-structures extras)
    3531
     32 (require-extension srfi-1 srfi-4 iset matchable )
    3633
    3734(define (graph-scc:error x . rest)
     
    103100            f initial))
    104101
     102)
  • release/4/graph-scc/trunk/graph-scc.setup

    r12055 r14362  
    1 
    2 (define has-exports? (string>=? (chicken-version) "2.310"))
     1;;;; -*- Hen -*-
    32
    43(define (dynld-name fn)         
    54  (make-pathname #f fn ##sys#load-dynamic-extension))   
    65
    7 (compile -O2 -d0 -s
    8          ,@(if has-exports? '(-check-imports -emit-exports graph-scc.exports) '())
    9          graph-scc.scm -lchicken -ldl -lm)
     6(compile -O2 -d0 -s graph-scc.scm -j graph-scc)
     7(compile -O2 -d0 -s graph-scc.import.scm)
    108
    11 (run (csi -qbs graph-scc-eggdoc.scm > graph-scc.html))
     9(run (csi -s graph-scc-eggdoc.scm > graph-scc.html))
    1210
    1311(install-extension
     
    1715
    1816  ; Files to install for your extension:
    19   `(,(dynld-name "graph-scc") "graph-scc.html"
    20     ,@(if has-exports? '("graph-scc.exports") (list)) )
     17  `(,(dynld-name "graph-scc") ,(dynld-name "graph-scc.import") )
    2118
    2219  ; Assoc list with properties for your extension:
    23   `((version 1.7)
     20  `((version 1.8)
    2421    (documentation "graph-scc.html")
    25     ,@(if has-exports? `((exports "graph-scc.exports")) (list)) ))
     22    ))
     23
  • release/4/graph-scc/trunk/tests/run.scm

    r6972 r14362  
    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-scc)
    36 (require-extension testbase)
    37 (require-extension testbase-output-compact)
    38 
     29(require-library srfi-1 srfi-13 digraph graph-scc test)
     30(import srfi-1 srfi-13 digraph graph-scc test)
    3931
    4032(define used-by
     
    4941     (cons 'zag_o 'libzigzag_a) (cons 'libzigzag_a 'killerapp)))
    5042
     43(define node-list
     44  (delete-duplicates
     45   (concatenate (list (map car used-by) (map cdr used-by)))))
    5146
    52 (define-expect-unary pair?)
     47(define node-ids
     48  (list-tabulate (length node-list) values))
    5349
     50(define node-map  (zip node-list node-ids))
    5451
    55 (define-test scc-test "scc 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)) )
     52(test-group "graph-scc test"
     53           
     54  (let ((g (make-digraph 'depgraph "dependency graph")))
     55 
     56    ;; add the nodes to the graph
     57    (for-each (lambda (i n) ((g 'add-node!) i n))
     58              node-ids node-list)
    6759
    68 
    69   ;; can we make a graph
    70   (expect-set! g (make-digraph 'depgraph "dependency graph"))
     60    ;; make sure all nodes got inserted
     61    (test "add nodes to the graph"
     62          ((g 'nodes))
     63          '((14 killerapp)
     64            (13 libzigzag_a) (12 zag_o) (11 zag_cpp)
     65            (10 zig_o) (9 zig_cpp) (8 libfoobar_a) (7 bar_o)
     66            (6 bar_cpp) (5 foo_o) (4 foo_cpp) (3 zow_h) (2 boz_h)
     67            (1 yow_h) (0 dax_h)))
    7168 
    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)))
     69    ;; add the edges to the graph
     70    (for-each (lambda (e)
     71                (let* ((ni (car e))
     72                       (nj (cdr e))
     73                       (i (car (alist-ref ni node-map)))
     74                       (j (car (alist-ref nj node-map))))
     75                  ((g 'add-edge!) (list i j (format "~A->~A" ni nj)))))
     76              used-by)
    8577 
    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   (test-eval 'get-roots ((g 'roots)))
    100  
    101   (test-let ((roots  ((g 'roots)))
    102              (str    (open-output-string)))
    103 
    104             (test/equal 'graph-scc-fold
    105                         (graph-scc-fold g (lambda (scc ax) (cons scc ax)) (list))
    106                         '((2) (3) (8 0 1 6 7 4 5) (9) (10) (11) (12) (13) (14))))
    107 
    108   )
    109 
    110 
    111 (test::styler-set! scc-test test::output-style-compact)
    112 (run-test "scc test")
     78    (let ((roots  ((g 'roots)))
     79          (str    (open-output-string)))
     80      (test "test SCC fold"
     81       (graph-scc-fold g (lambda (scc ax) (cons scc ax)) (list))
     82       '((2) (3) (8 0 1 6 7 4 5) (9) (10) (11) (12) (13) (14))))
     83   
     84    ))
    11385
    11486           
Note: See TracChangeset for help on using the changeset viewer.