Use records instead of conss for nodes, alist for graphs
This commit is contained in:
parent
6d6d1eec18
commit
a3f0ee2eb9
23
demo.scm
23
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 red (create-color 1 0 0))
|
||||||
|
|
||||||
(define my-graph
|
(define graph1 (generate-web 10 10))
|
||||||
`(((10 . 10) (1))
|
(define graph2 (copy-tree graph1))
|
||||||
((30 . 20) () ,red)))
|
(assq-set! graph2 0 (set-node-color (assq-ref graph2 0) red))
|
||||||
|
(write-graphs-to-file (list graph1 graph2) "graph.gif")
|
||||||
(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"))
|
|
||||||
|
50
graphgif.scm
50
graphgif.scm
@ -1,7 +1,8 @@
|
|||||||
(define-module (graphgif))
|
(define-module (graphgif))
|
||||||
|
|
||||||
(use-modules (cairo)
|
(use-modules (cairo)
|
||||||
(srfi srfi-1))
|
(srfi srfi-1)
|
||||||
|
(srfi srfi-9 gnu))
|
||||||
|
|
||||||
(re-export (cairo-pattern-create-rgb . create-color))
|
(re-export (cairo-pattern-create-rgb . create-color))
|
||||||
|
|
||||||
@ -15,17 +16,28 @@
|
|||||||
(define-public black (cairo-pattern-create-rgb 0 0 0))
|
(define-public black (cairo-pattern-create-rgb 0 0 0))
|
||||||
(define-public white (cairo-pattern-create-rgb 1 1 1))
|
(define-public white (cairo-pattern-create-rgb 1 1 1))
|
||||||
|
|
||||||
|
(define-immutable-record-type <node>
|
||||||
|
(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)
|
(define (edge-painter cr graph)
|
||||||
(lambda (node)
|
(lambda (node)
|
||||||
(cairo-set-source cr black)
|
(cairo-set-source cr black)
|
||||||
(let ([x (caar node)]
|
(let ([x (car (node-coords node))]
|
||||||
[y (cdar node)]
|
[y (cdr (node-coords node))]
|
||||||
[edges (cadr node)])
|
[edges (node-edges node)])
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (edge)
|
(lambda (edge)
|
||||||
(let* ([other (list-ref graph edge)]
|
(let* ([other (assq-ref graph edge)]
|
||||||
[ox (caar other)]
|
[ox (car (node-coords other))]
|
||||||
[oy (cdar other)])
|
[oy (cdr (node-coords other))])
|
||||||
(cairo-move-to cr x y)
|
(cairo-move-to cr x y)
|
||||||
(cairo-line-to cr ox oy)
|
(cairo-line-to cr ox oy)
|
||||||
(cairo-stroke cr)))
|
(cairo-stroke cr)))
|
||||||
@ -33,11 +45,9 @@
|
|||||||
|
|
||||||
(define (node-painter cr)
|
(define (node-painter cr)
|
||||||
(lambda (node)
|
(lambda (node)
|
||||||
(let ([x (caar node)]
|
(let ([x (car (node-coords node))]
|
||||||
[y (cdar node)]
|
[y (cdr (node-coords node))]
|
||||||
[color (if (null? (cddr node))
|
[color (or (node-color node) white)])
|
||||||
white
|
|
||||||
(caddr node))])
|
|
||||||
(cairo-arc cr x y 4. 0. tau)
|
(cairo-arc cr x y 4. 0. tau)
|
||||||
(cairo-set-source cr color)
|
(cairo-set-source cr color)
|
||||||
(cairo-fill-preserve cr)
|
(cairo-fill-preserve cr)
|
||||||
@ -53,8 +63,8 @@
|
|||||||
(cairo-rectangle cr 0 0 400 400)
|
(cairo-rectangle cr 0 0 400 400)
|
||||||
(cairo-set-source cr white)
|
(cairo-set-source cr white)
|
||||||
(cairo-fill cr)
|
(cairo-fill cr)
|
||||||
(for-each paint-edges graph)
|
(for-each paint-edges (map cdr graph))
|
||||||
(for-each paint-nodes graph)
|
(for-each paint-nodes (map cdr graph))
|
||||||
(cairo-destroy cr)
|
(cairo-destroy cr)
|
||||||
surface))
|
surface))
|
||||||
|
|
||||||
@ -91,10 +101,12 @@
|
|||||||
|
|
||||||
(define-public (generate-web w h)
|
(define-public (generate-web w h)
|
||||||
(define (make-node i)
|
(define (make-node i)
|
||||||
(list
|
(cons i
|
||||||
(cons (+ (* 30 (idx->x i w)) 10)
|
(node
|
||||||
(+ (* 30 (idx->y i w)) 10))
|
(cons (+ (* 30 (idx->x i w)) 10)
|
||||||
(idx->edges i w)))
|
(+ (* 30 (idx->y i w)) 10))
|
||||||
|
(idx->edges i w)
|
||||||
|
#f)))
|
||||||
(let loop ([i 0]
|
(let loop ([i 0]
|
||||||
[lst '()])
|
[lst '()])
|
||||||
(if (>= i (* w h))
|
(if (>= i (* w h))
|
||||||
@ -106,7 +118,7 @@
|
|||||||
;;;;;;;;;;;;
|
;;;;;;;;;;;;
|
||||||
|
|
||||||
(define (output-to-file surfaces filename)
|
(define (output-to-file surfaces filename)
|
||||||
(define pngdir (mkdtemp "graphgif_XXXXXX"))
|
(define pngdir (mkdtemp "/tmp/graphgif_XXXXXX"))
|
||||||
(do ([i 1 (1+ i)]
|
(do ([i 1 (1+ i)]
|
||||||
[surfaces surfaces (cdr surfaces)])
|
[surfaces surfaces (cdr surfaces)])
|
||||||
((null? surfaces))
|
((null? surfaces))
|
||||||
|
Loading…
Reference in New Issue
Block a user