source: project/release/3/rgraph/trunk/rgraph-base.scm @ 33923

Last change on this file since 33923 was 10005, checked in by Kon Lovett, 13 years ago

Fixes for wrong param order w/ srfi-69 procs, misspelled varaiables, no feature for srfi-40, missing param. (Did this ever work?).

File size: 5.0 KB
Line 
1; Copyright (c) 2004, Jonah Nathaniel Beckford
2; All rights reserved.
3;
4; Redistribution and use in source and binary forms, with or without
5; modification, are permitted provided that the following conditions
6; are met:
7;
8;   Redistributions of source code must retain the above copyright
9;   notice, this list of conditions and the following disclaimer.
10;
11;   Redistributions in binary form must reproduce the above copyright
12;   notice, this list of conditions and the following disclaimer in
13;   the documentation and/or other materials provided with the
14;   distribution.
15;
16;   Neither the name of the author nor the names of its contributors
17;   may be used to endorse or promote products derived from this
18;   software without specific prior written permission.
19;
20; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
23; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
24; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
25; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
26; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
27; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
28; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
29; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
30; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
31; OF THE POSSIBILITY OF SUCH DAMAGE.
32;
33; jonah@usermail.com
34
35(cond-expand
36  [chicken
37    (require-extension srfi-69) ; hash-table
38    (require-extension srfi-40)]
39  (else))
40
41(cond-expand
42  [(and chicken srfi-40)
43    (define (hash-table->stream ht)
44      (##sys#check-structure ht 'hash-table 'hash-table->stream)
45      (let* ([vec (##sys#slot ht 1)]
46             [len (##sys#size vec)] )
47        (let iter ([i 0] [lst stream-null])
48          (stream-delay
49            (if (fx>= i len)
50                lst
51                (let loop ([bucket (##sys#slot vec i)]
52                           [lst lst])
53                  (if (null? bucket)
54                      (iter (fx+ i 1) lst)
55                      (loop (##sys#slot bucket 1)
56                            (let ([x (##sys#slot bucket 0)])
57                              (stream-cons (cons (##sys#slot x 0) (##sys#slot x 1))
58                                           lst))))))))))]
59  (else))
60
61#;
62(cond-expand
63  [(and chicken srfi-40)
64    (define (hash-table->stream ht)
65      (stream-delay
66       (hash-table-fold ht
67                        (lambda (k v lst) (stream-cons (cons k v) lst))
68                        stream-null)) ) ]
69  (else))
70
71(cond-expand
72  [srfi-40
73    (define (vector->stream vct)
74      (let ([l (vector-length vct)])       
75        (let iter ([i 0])
76          (stream-delay
77            (cond
78              [(= i l) stream-null]
79              [else (stream-cons (vector-ref vct i) (iter (add1 i)))])))))
80    (define (list->stream lst)
81      (let iter ([lst lst])
82        (stream-delay
83          (cond
84            [(null? lst) stream-null]
85            [else (stream-cons (car lst) (iter (cdr lst)))]))))
86
87    (define (stream->list strm)
88      (cond
89        [(null? strm) '()]
90        [else (let iter ([strm strm])
91                (if (stream-null? strm)
92                    '()
93                    (cons (stream-car strm)
94                      (iter (stream-cdr strm)))))]
95        ))
96   
97    (define (stream-append . strms)
98      (let iter ([strm stream-null] [lstrm strms])
99        (stream-delay
100         (cond
101          ((stream-null? strm)
102           (if (null? lstrm) 
103               stream-null 
104               (iter (car lstrm) (cdr lstrm))))
105          (else (stream-cons (stream-car strm) (iter (stream-cdr strm) lstrm)))))))
106    ]
107  (else))
108
109;; Get rid of dependency on SRFI-1
110(define (rgraph-count pred lst)
111  (let loop ([l lst] [i 0])
112    (if (null? l)
113        i
114        (loop (cdr l) (if (pred (car l)) (add1 i) i)))))
115
116(include "rgraph-prop.scm")
117(include "rgraph-vis.scm")
118
119;; Fill graph from a list of edges, where each edge is a pair of the
120;; form '(vertex1 . vertex2).  vertex1, vertex2, etc. must be
121;; comparable using eq? [or VERTEX-EQ? if defined].  Gets mutated
122;; graph.  Will fill internal property 'vertex-name if defined.
123(define (fill-graph! graph edges . vertex-eq?)
124  (define vertex-equal?
125    (cond [(pair? vertex-eq?) (car vertex-eq?)] [else eq?]))
126  (define h (make-hash-table vertex-equal? hash))
127  (define vertex-name (graph:get graph 'vertex-name))
128  (for-each
129    (lambda (edge)
130      (let* ([v1 (car edge)]
131             [v2 (cdr edge)]
132             [vertex1 (hash-table-ref/default h v1 #f)]
133             [vertex2 (hash-table-ref/default h v2 #f)])
134        (cond [(not vertex1)
135               (set! vertex1 (graph:add-vertex! graph))
136               (when vertex-name (prop:put! vertex-name vertex1 v1))
137               (hash-table-set! h v1 vertex1)])
138        (cond [(not vertex2)
139               (set! vertex2 (graph:add-vertex! graph))
140               (when vertex-name (prop:put! vertex-name vertex2 v2))
141               (hash-table-set! h v2 vertex2)])
142        (graph:add-edge! graph vertex1 vertex2)))
143    edges)
144  graph)
145
Note: See TracBrowser for help on using the repository browser.