(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")