diff --git a/graphgif.scm b/graphgif.scm index b5aad1b..507c079 100644 --- a/graphgif.scm +++ b/graphgif.scm @@ -1,19 +1,17 @@ (define-module (graphgif)) - (use-modules (cairo) (d-) (srfi srfi-1) (srfi srfi-9 gnu) (srfi srfi-11) (srfi srfi-43)) - (re-export (cairo-pattern-create-rgb . create-color)) ;;;;;;;;;;;;;;;;;;; ;; Basic Drawing ;; ;;;;;;;;;;;;;;;;;;; -(define-public pi 3.14159) +(define-public pi 3.14159) ;; Good enough (define-public tau (* 2 pi)) (define-public black (cairo-pattern-create-rgb 0 0 0)) @@ -31,11 +29,11 @@ node-color set-node-color) (define (edge-painter cr graph) + "Creates a closure that draws the edges of graph using cr" (lambda (node) (cairo-set-source cr black) - (let ([x (car (node-coords node))] - [y (cdr (node-coords node))] - [edges (node-edges node)]) + (let-values ([(x y) (car+cdr (node-coords node))] + [edges (node-edges node)]) (for-each (lambda (edge) (let* ([other (assq-ref graph edge)] @@ -47,10 +45,10 @@ edges)))) (define (node-painter cr) + "Creates a closure that draws the nodes of graph using cr" (lambda (node) - (let ([x (car (node-coords node))] - [y (cdr (node-coords node))] - [color (or (node-color node) white)]) + (let-values ([(x y) (car+cdr (node-coords node))] + [color (or (node-color node) white)]) (cairo-arc cr x y 4. 0. tau) (cairo-set-source cr color) (cairo-fill-preserve cr) @@ -58,6 +56,7 @@ (cairo-stroke cr)))) (define-public (draw-abstract-graph graph) + "Creates a cairo surface with graph drawn on it" (let* ([surface (cairo-image-surface-create 'rgb24 400 400)] [cr (cairo-create surface)]) (define paint-edges (edge-painter cr graph)) @@ -76,15 +75,19 @@ ;;;;;;;;;;;;;;;;;;;;;; (define (idx->x i w) + "Given i and width w, returns the x value" (modulo i w)) (define (idx->y i w) + "Given i and width w, returns the y value" (quotient i w)) (define (xy->idx x y w) + "Returns the index of x y on width x in a linear buffer" (+ (* y w) x)) (define (idx->edges i w) + "Returns the edges needed to fully connect i on graph width w" (filter-map (lambda (offset) (let* ([x (idx->x i w)] @@ -97,10 +100,13 @@ (< ox w) (xy->idx ox oy w)))) ;; Auto-connect these directions if legal indices - '(( 0 . -1) - (-1 . 0) - (-1 . -1) - (+1 . -1)))) + ;; This combined with forwards and back connections create a + ;; fully connected graph + '(( 0 . -1) ;; Above + (-1 . 0) ;; Right + (-1 . -1) ;; Right-above + (+1 . -1) ;; Left above + ))) (define lset-unionq (partial lset-union eq?)) @@ -129,6 +135,7 @@ graph)) (define-public (connect-bidirectionally graph) + "Takes a directed graph and connects all edges to make it fully bidirectional" (if (null? graph) '() (let* ([idx (caar graph)] [node (cdar graph)]) @@ -139,6 +146,7 @@ idx))))) (define-public (generate-web w h) + "Creates a fully connected graph of width w and height h" (define (make-node i) (cons i (node @@ -153,6 +161,7 @@ (loop (1+ i) (cons (make-node i) lst))))) (define-public (remove-rect graph w x1 y1 x2 y2) + "Removes a rectangular section of a fully connected rectangular graph" ;; Assumption is that is a graph generated by generate-web ;; and that it has not been re-indexed ;; x1 < x2, y1 < y2 @@ -180,7 +189,6 @@ ;; ALGORITHMS!!! ;; ;;;;;;;;;;;;;;;;;;; -;; Heap algorithms (define-public (heap-insert priority item heap) (define (fix-up! i heap) (if (zero? i) @@ -217,10 +225,15 @@ (vector-set! new-heap 0 (vector-ref heap (1- (vector-length heap)))) (fix-down! new-heap 0)))) +(define (make-inf-queue graph) + "Creates a heap of the graph where all priorities are +inf" + (list->vector + (map (lambda (entry) + (cons (inf) (car entry))) + graph))) + (define* (djikstra graph source sink #:optional update) - (define unvisited (list->vector (map (lambda (entry) - (cons (inf) (car entry))) - graph))) + (define unvisited (make-inf-queue graph)) (let iter ([heap (heap-insert 0 source unvisited)] [visited '()]) (define-values (dist idx) (car+cdr (heap-peek heap))) @@ -239,14 +252,11 @@ (export djikstra) (define* (a* graph source sink #:optional update) - "Uses the Chebychev distance as a heuristic" - (define (chebychev idx) + (define (chebychev idx) ;; Uses the Chebychev distance as a heuristic (let-values ([(x1 y1) (car+cdr (node-coords (assv-ref graph idx)))] [(x2 y2) (car+cdr (node-coords (assv-ref graph sink)))]) (max (abs (- x1 x2)) (abs (- y1 y2))))) - (define unvisited (list->vector (map (lambda (entry) - (cons (inf) (car entry))) - graph))) + (define unvisited (make-inf-queue graph)) (let iter ([heap (heap-insert (chebychev source) source unvisited)] [visited '()]) (define-values (dist idx) (car+cdr (heap-peek heap))) @@ -269,6 +279,7 @@ ;;;;;;;;;;;; (define (output-to-file filename surface-gen) + "Takes a filename and a coroutine to generate surfaces, and creates an animation" (define pngdir (mkdtemp "/tmp/graphgif_XXXXXX")) (let loop ([surface (surface-gen)] [i 1]) @@ -282,11 +293,8 @@ "-loop" "0" filename)) (define-public (write-graphs-to-file filename graph-gen) + "Takes a filename and a couroutine to generate graphs, and creates an animation" (define (surface-gen) (let ([graph (graph-gen)]) (and graph (draw-abstract-graph graph)))) (output-to-file filename surface-gen)) - -;; Local Variables: -;; geiser-scheme-implementation: guile -;; End: