source: project/rgraph/rgraph-base.scm @ 1

Last change on this file since 1 was 1, checked in by azul, 15 years ago

Import everything.

File size: 5.4 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 extras) ; hash-table
38    (define (hash-table-map proc ht)
39      (##sys#check-structure ht 'hash-table 'hash-table->list)
40      (let* ([vec (##sys#slot ht 1)]
41             [len (##sys#size vec)] )
42        (let loop ([i 0] [lst '()])
43          (if (fx>= i len)
44              lst
45              (let loop2 ([bucket (##sys#slot vec i)] [lst lst])
46                (if (null? bucket)
47                    (loop (fx+ i 1) lst)
48                    (loop2 (##sys#slot bucket 1)
49                      (let ([x (##sys#slot bucket 0)])
50                        (cons
51                          (proc (##sys#slot x 0) (##sys#slot x 1))
52                          lst)))))))))
53
54    ]
55  (else))
56
57(cond-expand
58  [(and chicken srfi-40)
59    (define (hash-table->stream ht)
60      (##sys#check-structure ht 'hash-table 'hash-table->list)
61      (let* ([vec (##sys#slot ht 1)]
62             [len (##sys#size vec)] )
63        (let iter ([i 0] [lst stream-null])
64          (stream-delay
65            (if (fx>= i len)
66                lst
67                (let loop ([bucket (##sys#slot vec i)] [lst lst])
68                  (if (null? bucket)
69                      (iter (fx+ i 1) lst)
70                      (loop (##sys#slot bucket 1)
71                        (let ([x (##sys#slot bucket 0)])
72                          (stream-cons
73                            (cons (##sys#slot x 0) (##sys#slot x 1))
74                            lst))))))))))]
75  (else))
76
77(cond-expand
78  [srfi-40
79    (define (vector->stream vct)
80      (let ([l (vector-length vct)])       
81        (let iter ([i 0])
82          (stream-delay
83            (cond
84              [(= i l) stream-null]
85              [else (stream-cons (vector-ref vct i) (iter (add1 i)))])))))
86    (define (list->stream lst)
87      (let iter ([lst lst])
88        (stream-delay
89          (cond
90            [(null? lst) stream-null]
91            [else (stream-cons (car lst) (iter (cdr lst)))]))))
92
93    (define (stream->list strm)
94      (cond
95        [(null? strm) '()]
96        [else (let iter ([strm strm])
97                (if (stream-null? strm)
98                    '()
99                    (cons (stream-car strm)
100                      (iter (stream-cdr strm)))))]
101        ))
102   
103    (define (stream-append . strms)
104      (let iter ([strm stream-null] [lstrm strms])
105        (stream-delay
106         (cond
107          ((stream-null? strm)
108           (if (null? lstrm) 
109               stream-null 
110               (iter (car lstrm) (cdr lstrm))))
111          (else (stream-cons (stream-car strm) (iter (stream-cdr strm) lstrm)))))))
112    ]
113  (else))
114
115;; Get rid of dependency on SRFI-1
116(define (rgraph-count pred lst)
117  (let loop ([l lst] [i 0])
118    (if (null? l)
119        i
120        (loop (cdr l) (if (pred (car l)) (add1 i) i)))))
121
122(include "rgraph-prop.scm")
123(include "rgraph-vis.scm")
124
125;; Fill graph from a list of edges, where each edge is a pair of the
126;; form '(vertex1 . vertex2).  vertex1, vertex2, etc. must be
127;; comparable using eq? [or VERTEX-EQ? if defined].  Gets mutated
128;; graph.  Will fill internal property 'vertex-name if defined.
129(define (fill-graph! graph edges . vertex-eq?)
130  (define vertex-equal?
131    (cond [(pair? vertex-eq?) (car vertex-eq?)] [else eq?]))
132  (define h (make-hash-table vertex-equal?))
133  (define vertex-name (graph:get graph 'vertex-name))
134  (for-each
135    (lambda (edge)
136      (let* ([v1 (car edge)]
137             [v2 (cdr edge)]
138             [vertex1 (hash-table-ref/default h v1 #f)]
139             [vertex2 (hash-table-ref/default h v2 #f)])
140        (cond [(not vertex1)
141               (set! vertex1 (graph:add-vertex! graph))
142               (when vertex-name (prop:put! vertex-name vertex1 v1))
143               (hash-table-set! h v1 vertex1)])
144        (cond [(not vertex2)
145               (set! vertex2 (graph:add-vertex! graph))
146               (when vertex-name (prop:put! vertex-name vertex2 v2))
147               (hash-table-set! h v2 vertex2)])
148        (graph:add-edge! graph vertex1 vertex2)))
149    edges)
150  graph)
151
Note: See TracBrowser for help on using the repository browser.