god let's actually put this in source control

This commit is contained in:
Dane Johnson 2024-03-29 21:52:18 -05:00
commit a7909e1a7c
2 changed files with 74 additions and 0 deletions

BIN
graph.png Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 2.3 KiB

74
graphgif.scm Normal file
View File

@ -0,0 +1,74 @@
#!/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 (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: