93 lines
2.1 KiB
Scheme
93 lines
2.1 KiB
Scheme
#!/usr/bin/guile -s
|
|
!#
|
|
(use-modules (cairo))
|
|
|
|
;;;;;;;;;;;;;;;;;;;
|
|
;; Basic Drawing ;;
|
|
;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define pi 3.14159)
|
|
(define tau (* 2 pi))
|
|
|
|
(define black (cairo-pattern-create-rgb 0 0 0))
|
|
(define white (cairo-pattern-create-rgb 1 1 1))
|
|
(define red (cairo-pattern-create-rgb 1 0 0))
|
|
|
|
(define my-graph
|
|
`(((10 . 10) (1) ,white)
|
|
((30 . 20) () ,red)))
|
|
|
|
(define more-complex-graph
|
|
`(((10 . 10) () ,white)
|
|
((40 . 10) (0) ,white)
|
|
((25 . 25) (0 1) ,white)
|
|
((10 . 40) (0 2 4) ,white)
|
|
((40 . 40) (1 2 3) ,white)))
|
|
|
|
(define-syntax-rule
|
|
(for x n stmt ...)
|
|
(let loop ([x 0]
|
|
[lst '()])
|
|
(if (< x n)
|
|
(loop (1+ x)
|
|
(cons lst (stmt i)))
|
|
lst)))
|
|
|
|
(define large-web
|
|
(let ([lst '()])
|
|
(do (i (1+ i))
|
|
((> i 10))
|
|
(do (j (1+ j))
|
|
((> j 10))
|
|
(set! lst (cons `((,i . ,j)
|
|
,(map ))))))))
|
|
|
|
(define (edge-painter cr graph)
|
|
(lambda (node)
|
|
(cairo-set-source cr black)
|
|
(let ([x (caar node)]
|
|
[y (cdar node)]
|
|
[edges (cadr node)])
|
|
(for-each
|
|
(lambda (edge)
|
|
(let* ([other (list-ref graph edge)]
|
|
[ox (caar other)]
|
|
[oy (cdar other)])
|
|
(cairo-move-to cr x y)
|
|
(cairo-line-to cr ox oy)
|
|
(cairo-stroke cr)))
|
|
edges))))
|
|
|
|
(define (node-painter cr)
|
|
(lambda (node)
|
|
(let ([x (caar node)]
|
|
[y (cdar node)]
|
|
[color (caddr node)])
|
|
(cairo-arc cr x y 4. 0. tau)
|
|
(cairo-set-source cr color)
|
|
(cairo-fill-preserve cr)
|
|
(cairo-set-source cr black)
|
|
(cairo-stroke cr))))
|
|
|
|
(define (draw-abstract-graph graph)
|
|
(let* ([surface (cairo-image-surface-create 'argb32 400 400)]
|
|
[cr (cairo-create surface)])
|
|
(define paint-edges (edge-painter cr graph))
|
|
(define paint-nodes (node-painter cr))
|
|
;; White background
|
|
(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)
|
|
(cairo-destroy cr)
|
|
surface))
|
|
|
|
(define my-surface (draw-abstract-graph more-complex-graph))
|
|
(cairo-surface-write-to-png my-surface "graph.png")
|
|
(cairo-surface-destroy my-surface)
|
|
|
|
;; Local Variables:
|
|
;; geiser-scheme-implementation: guile
|
|
;; End:
|