On 01/15/2017 11:59 PM, Ludovic Courtès wrote:
Hi!
Michael Vehrs <[email protected]> skribis:
I would like to become familiar with the Skribilo source code. Is
there a simple janitorial task I could attempt? Replacing skribe-error
seems a plausible candidate, unless there are special considerations.
Indeed, this is a good candidate.
‘TODO’ has some other items.
Thanks,
Ludo’.
Alright, I'll have a look at that, then. I wasn't sure whether all TODO
items were still up to date. Meanwhile, here is a small pie charting
program I wrote. It uses guile-cairo. In my opinion, the charts it
generates are at least as good as those generated by ploticus. It can
also generate textures, which is mentioned as a wish list item in the
manual.
Regards
Michael
(use-modules
(ice-9 match)
(ice-9 optargs)
(srfi srfi-1)
(srfi srfi-11)
(cairo))
;;; Sensible defaults
(define PI 245850922/78256779)
(define *pie-margin* 40)
(define *finger-length* 20)
(define *label-gap* 10)
(define *pattern-width* 40)
(define *pattern-height* 40)
;;; Utility procedures
(define polar->cartesian
(lambda (radius angle)
(values (* radius (cos angle))
(* radius (sin angle)))))
(define needs-label?
(lambda (label label-style)
(and label (not (eq? label-style 'legend)))))
(define join-extents
(lambda (extent1 . args)
(let ((extents (if (null? args) '((0 0 0 0)) args)))
(fold
(lambda (ex1 previous)
(map
(lambda (op v1 v2)
(op v1 v2))
(list min min max max) ex1 previous))
extent1
extents))))
(define polar->extents
(lambda (radius angle)
(let-values (((x y) (polar->cartesian radius angle)))
(join-extents (list x y x y)))))
(define calculate-total-weight
(lambda (slices)
(fold
(lambda (slice previous)
(let-keywords
slice #t
((weight 0))
(+ (car slice) previous)))
0 slices)))
;; useful macros borrowed from Andy Wingo's guile-charting
(define-syntax-rule (with-cairo cr body ...)
(begin
(cairo-save cr)
(call-with-values (lambda () body ...)
(lambda vals
(cairo-restore cr)
(apply values vals)))))
(define-syntax-rule (with-rgba cr r g b a body ...)
(with-cairo cr
(cairo-set-source-rgba cr r g b a)
body ...))
(define-syntax-rule (with-translate cr dx dy body ...)
(with-cairo cr
(cairo-translate cr dx dy)
body ...))
;; Drawing-related utility procedures
(define move-outward
(lambda (x fixed variable)
(if (< x 0)
(- x fixed variable)
(+ x fixed))))
(define calculate-finger-path
(lambda (cr radius detach angle label-style)
(let ((detached-radius (+ radius detach)))
(let-values (((x1 y1) (polar->cartesian (- detached-radius (/ *finger-length* 2)) angle))
((x2 y2) (polar->cartesian (+ detached-radius (/ *finger-length* 2)) angle)))
(let ((x3 (if (eq? label-style 'long-fingers)
;; ignore detach
(let ((finger-length (+ radius *pie-margin*)))
(if (< x2 0) (- finger-length) finger-length))
(move-outward x2 *finger-length* 0))))
(values x1 y1 x2 y2 x3))))))
;;; Patterns
(define create-pattern
(lambda* (stride #:rest args)
(let* ((surface (cairo-image-surface-create
'argb32 *pattern-width* *pattern-height*))
(cr (cairo-create surface))
(pattern (cairo-pattern-create-for-surface surface))
(offset (/ stride 2)))
(cairo-pattern-set-extend pattern 'repeat)
(for-each
(lambda (arg)
(case arg
((vertical)
(let loop ((x offset))
(if (< x *pattern-width*)
(begin
(cairo-move-to cr x 0)
(cairo-line-to cr x *pattern-height*)
(cairo-stroke cr)
(loop (+ x stride))))))
((horizontal)
(let loop ((y offset))
(if (< y *pattern-height*)
(begin
(cairo-move-to cr 0 y)
(cairo-line-to cr *pattern-height* y)
(cairo-stroke cr)
(loop (+ y stride))))))
((rising)
(let loop ((x offset)
(y offset))
(if (or (< x *pattern-width*)
(< y *pattern-height*))
(begin
(cairo-move-to cr x 0)
(cairo-line-to cr 0 y)
(cairo-move-to cr (- *pattern-width* x) *pattern-height*)
(cairo-line-to cr *pattern-width* (- *pattern-height* y))
(cairo-stroke cr)
(loop (+ x stride) (+ y stride))))))
((falling)
(let loop ((x offset)
(y offset))
(if (or (< x *pattern-width*)
(< y *pattern-height*))
(begin
(cairo-move-to cr x 0)
(cairo-line-to cr *pattern-width* (- *pattern-height* y))
(cairo-move-to cr 0 y)
(cairo-line-to cr (- *pattern-width* x) *pattern-height*)
(cairo-stroke cr)
(loop (+ x stride) (+ y stride))))))
))
args)
pattern)))
;;; Drawing procedures
;;; assume we are at center of circle
(define draw-slice
(lambda* (cr radius start stop #:key fill-pattern fill-color stroke-color
(detach 0) label label-style #:allow-other-keys)
(let ((angle (+ start (/ (- stop start) 2))))
(with-cairo
cr
(let-values (((cx cy)
(if (= 0 detach)
(values 0 0)
(polar->cartesian detach angle))))
(cairo-arc cr cx cy radius start stop)
(cairo-line-to cr cx cy)
(cairo-close-path cr))
;; fill
(match fill-color
((r g b a)
(with-rgba cr r g b a
(cairo-fill-preserve cr)))
(_ #t))
(if fill-pattern
(with-cairo cr
(cairo-set-source cr fill-pattern)
(cairo-fill-preserve cr)))
;; stroke
(match stroke-color
((r g b a)
(with-rgba cr r g b a
(cairo-stroke cr)))
('none (cairo-new-path cr))
(_ (cairo-stroke cr)))
;; label
(if (needs-label? label label-style)
(draw-label cr radius detach angle label label-style))
))))
(define draw-finger
(lambda (cr radius detach angle label-style)
(let-values (((x1 y1 x2 y2 x3)
(calculate-finger-path cr radius detach angle label-style)))
(cairo-move-to cr x1 y1)
(cairo-line-to cr x2 y2)
(cairo-line-to cr x3 y2)
(cairo-stroke cr)
(values x3 y2))))
(define draw-label
(lambda (cr radius detach angle label label-style)
(let* ((extents (cairo-text-extents cr label))
(label-width (f64vector-ref extents 2))
(label-height (f64vector-ref extents 3)))
(let-values
(((x y)
(case label-style
((long-fingers short-fingers)
(draw-finger cr radius detach angle label-style))
((inside)
(polar->cartesian (/ (+ radius detach) 2) angle))
((outside)
(polar->cartesian (+ radius detach (/ *finger-length* 2)) angle)))))
;; add width of the label
(cairo-move-to cr (move-outward x *label-gap* label-width)
(+ y (/ label-height 2))))
(cairo-show-text cr label)
(cairo-stroke cr))))
(define draw-legend
(lambda (cr slices x y)
(fold
(lambda (slice y)
(let-keywords*
(cdr slice) #t
((label "")
(fill-pattern #f)
(stroke-color #f)
(fill-color #f))
(let* ((extents (cairo-text-extents cr label))
(label-width (f64vector-ref extents 2))
(label-height (f64vector-ref extents 3)))
(with-cairo
cr
(cairo-rectangle cr x y label-height (- label-height))
(match fill-color
((r g b a)
(with-rgba cr r g b a
(cairo-fill cr)))
(_ #t))
(if fill-pattern
(begin
(with-cairo cr
(cairo-set-source cr fill-pattern)
(cairo-fill-preserve cr))
(cairo-stroke cr))))
(cairo-move-to cr (+ x label-height *label-gap*) y)
(cairo-show-text cr label)
(+ y (* 3/2 label-height)))))
y
slices)))
(define draw-pie-chart
(lambda* (slices #:key (initial-angle (* 3/2 PI)) total radius filename label-style)
(let* ((total (or total (calculate-total-weight slices)))
(chart-extents (calculate-chart-extents slices #:initial-angle initial-angle
#:total total #:radius radius
#:label-style label-style))
(min-x (abs (list-ref chart-extents 0)))
(min-y (abs (list-ref chart-extents 1)))
(max-x (list-ref chart-extents 2))
(max-y (list-ref chart-extents 3))
(total-width (+ min-x max-x *pie-margin* *pie-margin*))
(total-height (+ min-y max-y *pie-margin* *pie-margin*))
(surface (cairo-image-surface-create 'argb32
total-width total-height))
(cr (cairo-create surface)))
(with-translate
cr (+ min-x *pie-margin*) (+ min-y *pie-margin*)
(cairo-set-font-size cr 12)
(fold
(lambda (slice start)
(let-keywords*
(cdr slice) #t
((weight 0)
(stop (+ start (* 2 PI (/ weight total)))))
(apply draw-slice cr radius start stop
(append (list #:label-style label-style) (cdr slice)))
stop))
initial-angle
slices)
(if (eq? label-style 'legend)
(draw-legend cr slices (+ radius *pie-margin*) (- radius))))
(cairo-surface-write-to-png (cairo-get-target cr) filename))))
;;; Extent calculation procedures
(define calculate-label-extents
(lambda (cr radius detach angle label label-style)
(let* ((text-extents (cairo-text-extents cr label))
(label-width (+ (f64vector-ref text-extents 2) *label-gap*))
(label-height (/ (f64vector-ref text-extents 3) 2)))
(let-values (((x y)
(case label-style
((long-fingers short-fingers)
(let-values (((x1 y1 x2 y2 x3)
(calculate-finger-path cr radius detach angle label-style)))
(values x3 y2)))
((inside)
(polar->cartesian (/ radius 2) angle))
((outside)
(polar->cartesian (+ radius (/ *finger-length* 2)) angle)))))
(let* ((x ((if (negative? x) - +) x label-width))
(y ((if (negative? y) - +) y label-height)))
(join-extents (list x y x y)))))))
(define calculate-slice-extents
(lambda (cr radius start stop label label-style detach)
(let* ((angle (+ start (/ (- stop start) 2)))
(detached (+ radius detach))
(slice-extents
(fold
(lambda (phi previous)
(if (< start phi stop)
(join-extents (polar->extents radius phi) previous)
previous))
(join-extents (polar->extents detach angle)
(polar->extents detached start)
(polar->extents detached stop))
(list (* PI 1/2) PI (* 3/2 PI) (* 2 PI)))))
(if (needs-label? label label-style)
(let ((label-extents (calculate-label-extents cr radius detach angle label label-style)))
(join-extents slice-extents label-extents))
slice-extents))
))
(define calculate-legend-extents
(lambda (cr slices x y)
(let loop ((todo slices)
(y y)
(extent (list 0 y x 0)))
(if (null? todo)
extent
(let-keywords*
(cdr (car slices)) #t
((label ""))
(let* ((extents (cairo-text-extents cr label))
(label-width (f64vector-ref extents 2))
(label-height (f64vector-ref extents 3))
(max-x (+ x label-width label-height *label-gap*))
(max-y (+ y (/ label-height 2))))
(loop (cdr todo)
(+ y (* 3/2 label-height))
(join-extents extent (list max-x max-y max-x max-y)))))))))
(define calculate-chart-extents
(lambda* (slices #:key (initial-angle (* 3/2 PI)) total radius label-style)
(let* ((total (or total (calculate-total-weight slices)))
(surface (cairo-image-surface-create 'argb32 10 10))
(cr (cairo-create surface)))
(with-cairo
cr
(cairo-set-font-size cr 12)
(let loop ((todo slices)
;; min-x min-y max-x max-y
(extents (list (- radius) (- radius) radius radius))
(start initial-angle))
(if (null? todo)
(if (eq? label-style 'legend)
(join-extents extents (calculate-legend-extents cr slices (+ radius *pie-margin*) (- radius)))
extents)
(let ((slice (car todo)))
(let-keywords*
(cdr slice) #t
((weight 0)
(detach 0)
(label #f))
(let ((stop (+ start (* 2 PI (/ weight total)))))
(loop (cdr todo)
(join-extents
extents
(calculate-slice-extents cr radius start stop label label-style detach))
stop)))
)))))))
;;; Examples
(draw-pie-chart `((slice #:weight 8
#:fill-color (0 0 0 0.5)
#:stroke-color (0 0 0 1)
#:label "Hezbollah militants")
(slice #:weight 42
#:fill-color (0 0 1 0.5)
#:stroke-color (0 0 1 1)
#:label "soldiers")
(slice #:weight 317
#:fill-color (1 0 0 0.5)
#:stroke-color (1 0 0 1)
#:detach 20
#:label ,(format #f "civilians ~,2f%" (/ 3170 45))))
#:total 450 ;; to show the uncertainty on figures
#:radius 100
#:label-style 'long-fingers
#:filename "pie1.png")
(draw-pie-chart `((slice #:weight 8
#:fill-pattern ,(create-pattern 5 'horizontal)
#:label "Hezbollah militants")
(slice #:weight 42
#:fill-pattern ,(create-pattern 8 'horizontal 'vertical)
#:label "soldiers")
(slice #:weight 317
#:fill-pattern ,(create-pattern 10 'falling 'rising)
#:detach 20
#:label ,(format #f "civilians ~,2f%" (/ 3170 45))))
#:total 450 ;; to show the uncertainty on figures
#:radius 100
#:label-style 'short-fingers
#:filename "pie2.png")
(draw-pie-chart `((slice #:weight 8
#:fill-pattern ,(create-pattern 5 'horizontal)
#:label "Hezbollah militants")
(slice #:weight 42
#:fill-pattern ,(create-pattern 8 'horizontal 'vertical)
#:label "soldiers")
(slice #:weight 317
#:fill-pattern ,(create-pattern 10 'falling 'rising)
#:detach 20
#:label ,(format #f "civilians ~,2f%" (/ 3170 45))))
#:total 450 ;; to show the uncertainty on figures
#:radius 100
#:label-style 'legend
#:filename "pie3.png")
_______________________________________________
Skribilo-users mailing list
[email protected]
https://lists.nongnu.org/mailman/listinfo/skribilo-users
