diff --git a/demo.scm b/demo.scm index 57dbdae..6e52074 100644 --- a/demo.scm +++ b/demo.scm @@ -1,19 +1,10 @@ -(use-modules (graphgif)) +(use-modules (graphgif) + (srfi srfi-9 gnu) + (ice-9 copy-tree)) (define red (create-color 1 0 0)) -(define my-graph - `(((10 . 10) (1)) - ((30 . 20) () ,red))) - -(define more-complex-graph - `(((10 . 10) ()) - ((40 . 10) (0)) - ((25 . 25) (0 1)) - ((10 . 40) (0 2 4)) - ((40 . 40) (1 2 3)))) - -(let* ([graph1 (generate-web 10 10)] - [graph2 (list-copy graph1)]) - (set-car! graph2 (append (car graph2) `(,red))) - (write-graphs-to-file (list graph1 graph2) "graph.gif")) +(define graph1 (generate-web 10 10)) +(define graph2 (copy-tree graph1)) +(assq-set! graph2 0 (set-node-color (assq-ref graph2 0) red)) +(write-graphs-to-file (list graph1 graph2) "graph.gif") diff --git a/graphgif.scm b/graphgif.scm index 8b3101e..2ee0759 100644 --- a/graphgif.scm +++ b/graphgif.scm @@ -1,7 +1,8 @@ (define-module (graphgif)) (use-modules (cairo) - (srfi srfi-1)) + (srfi srfi-1) + (srfi srfi-9 gnu)) (re-export (cairo-pattern-create-rgb . create-color)) @@ -15,17 +16,28 @@ (define-public black (cairo-pattern-create-rgb 0 0 0)) (define-public white (cairo-pattern-create-rgb 1 1 1)) +(define-immutable-record-type + (node coords edges color) + node? + (coords node-coords set-node-coords) + (edges node-edges set-node-edges) + (color node-color set-node-color)) +(export node node? + node-coords set-node-coords + node-edges set-node-edges + node-color set-node-color) + (define (edge-painter cr graph) (lambda (node) (cairo-set-source cr black) - (let ([x (caar node)] - [y (cdar node)] - [edges (cadr node)]) + (let ([x (car (node-coords node))] + [y (cdr (node-coords node))] + [edges (node-edges node)]) (for-each (lambda (edge) - (let* ([other (list-ref graph edge)] - [ox (caar other)] - [oy (cdar other)]) + (let* ([other (assq-ref graph edge)] + [ox (car (node-coords other))] + [oy (cdr (node-coords other))]) (cairo-move-to cr x y) (cairo-line-to cr ox oy) (cairo-stroke cr))) @@ -33,11 +45,9 @@ (define (node-painter cr) (lambda (node) - (let ([x (caar node)] - [y (cdar node)] - [color (if (null? (cddr node)) - white - (caddr node))]) + (let ([x (car (node-coords node))] + [y (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) @@ -53,8 +63,8 @@ (cairo-rectangle cr 0 0 400 400) (cairo-set-source cr white) (cairo-fill cr) - (for-each paint-edges graph) - (for-each paint-nodes graph) + (for-each paint-edges (map cdr graph)) + (for-each paint-nodes (map cdr graph)) (cairo-destroy cr) surface)) @@ -91,10 +101,12 @@ (define-public (generate-web w h) (define (make-node i) - (list - (cons (+ (* 30 (idx->x i w)) 10) - (+ (* 30 (idx->y i w)) 10)) - (idx->edges i w))) + (cons i + (node + (cons (+ (* 30 (idx->x i w)) 10) + (+ (* 30 (idx->y i w)) 10)) + (idx->edges i w) + #f))) (let loop ([i 0] [lst '()]) (if (>= i (* w h)) @@ -106,7 +118,7 @@ ;;;;;;;;;;;; (define (output-to-file surfaces filename) - (define pngdir (mkdtemp "graphgif_XXXXXX")) + (define pngdir (mkdtemp "/tmp/graphgif_XXXXXX")) (do ([i 1 (1+ i)] [surfaces surfaces (cdr surfaces)]) ((null? surfaces))