dane/graphgif
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add function to bi-directionally connect a graph

Browse Source
This commit is contained in:
Dane Johnson 2024-10-25 14:04:42 -05:00
parent 332b4dc6b3
commit 151ecb1b1c
1 changed files with 52 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
graphgif.scm
View File

@ -100,6 +100,42 @@
(-1 . -1) (-1 . -1)
(+1 . -1)))) (+1 . -1))))
(define lset-unionq (partial lset-union eq?))
(define (forward-connect node graph idx)
(cons idx
(set-node-edges
node
(lset-unionq
(node-edges node)
(fold (lambda (entry set)
(if (memq idx (node-edges (cdr entry)))
(cons idx set)
set))
'()
graph)))))
(define (back-connect edges graph idx)
(map
(lambda (entry)
(cons (car entry)
(if (memq (car entry) edges)
(set-node-edges
(cdr entry)
(lset-unionq (node-edges (cdr entry)) `(,idx)))
(cdr entry))))
graph))
(define-public (connect-bidirectionally graph)
(if (null? graph) '()
(let* ([idx (caar graph)]
[node (cdar graph)])
(cons (forward-connect node (cdr graph) idx)
(back-connect
(node-edges node)
(connect-bidirectionally (cdr graph))
idx)))))
(define-public (generate-web w h) (define-public (generate-web w h)
(define (make-node i) (define (make-node i)
(cons i (cons i
@ -111,7 +147,7 @@
(let loop ([i 0] (let loop ([i 0]
[lst '()]) [lst '()])
(if (>= i (* w h)) (if (>= i (* w h))
(reverse lst) (connect-bidirectionally (reverse lst))
(loop (1+ i) (cons (make-node i) lst))))) (loop (1+ i) (cons (make-node i) lst)))))
(define-public (remove-rect graph w x1 y1 x2 y2) (define-public (remove-rect graph w x1 y1 x2 y2)
@ -121,21 +157,27 @@
(define edges-to-remove (define edges-to-remove
(unfold (lambda (s) (> s (xy->idx x2 y2 w))) (unfold (lambda (s) (> s (xy->idx x2 y2 w)))
identity identity
(lambda (s) (if (>= (idx->x s w) x2) (lambda (s)
(xy->idx x1 (1+ (idx->y s w)) w) (if (>= (idx->x s w) x2)
(1+ s))) (xy->idx x1 (1+ (idx->y s w)) w)
(1+ s)))
(xy->idx x1 y1 w))) (xy->idx x1 y1 w)))
(filter-map (filter-map
(lambda (idx/node) (lambda (idx/node)
(if (memq (car idx/node) edges-to-remove) (if (memq (car idx/node) edges-to-remove)
#f #f
(cons (car idx/node) (cons (car idx/node)
(set-node-edges (cdr idx/node) (set-node-edges
(remove (cdr idx/node)
(lambda (edge) (memq edge edges-to-remove)) (remove
(node-edges (cdr idx/node))))))) (lambda (edge) (memq edge edges-to-remove))
(node-edges (cdr idx/node)))))))
graph)) graph))
;;;;;;;;;;;;;;;;;;;
;; ALGORITHMS!!! ;;
;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;; ;;;;;;;;;;;;
;; Output ;; ;; Output ;;
;;;;;;;;;;;; ;;;;;;;;;;;;
@ -153,7 +195,8 @@
"-r" "1" "-loop" "0" filename)) "-r" "1" "-loop" "0" filename))
(define-public (write-graphs-to-file graphs filename) (define-public (write-graphs-to-file graphs filename)
(output-to-file (vector-map (lambda (_ graph) (draw-abstract-graph graph)) graphs) filename)) (output-to-file (vector-map (lambda (_ graph) (draw-abstract-graph graph)) graphs)
filename))
;; Local Variables: ;; Local Variables:
;; geiser-scheme-implementation: guile ;; geiser-scheme-implementation: guile