;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(import (rnrs)
        (surfage s27 random-bits)
        (ypsilon ffi)
        (ypsilon cairo)
        (agave misc random-weighted)
        )

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(random-source-randomize! default-random-source)

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define M_PI (* 2 (asin 1)))

(define (sq n) (* n n))

(define (norm v)
  (sqrt (+ (sq (vector-ref v 0))
           (sq (vector-ref v 1)))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (radians n)
  (* n (/ M_PI 180.0)))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-record-type rgba
  (fields (mutable red)
          (mutable green)
          (mutable blue)
          (mutable alpha)))

(define-record-type hsva
  (fields (mutable hue)
          (mutable saturation)
          (mutable value)
          (mutable alpha)))

(define (clone-hsva obj)
  (make-hsva (hsva-hue obj)
             (hsva-saturation obj)
             (hsva-value obj)
             (hsva-alpha obj)))

(define (hsva->rgba color)

  (let ((hue        (inexact (hsva-hue        color)))
        (saturation (inexact (hsva-saturation color)))
        (value      (inexact (hsva-value      color)))
        (alpha      (inexact (hsva-alpha      color))))

    (let ((Hi (mod (floor (/ hue 60.0)) 6.0)))

      (let ((f (- (/ hue 60.0) Hi))
            (p (* (- 1.0 saturation) value)))

        (let ((q (* (- 1.0 (*      f  saturation)) value))
              (t (* (- 1.0 (* (- 1.0 f) saturation)) value)))

          (case (exact Hi)
            ((0) (make-rgba value t   p   alpha))
            ((1) (make-rgba q   value p   alpha))
            ((2) (make-rgba p   value t   alpha))
            ((3) (make-rgba p   q   value alpha))
            ((4) (make-rgba t   p   value alpha))
            ((5) (make-rgba value p   q   alpha))))))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; (define cr #f)

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define color #f)

(define (adjust num)
   (lambda (val)
     (if (> num 0.0)
         (+ val (* (- 1.0 val) num))
         (+ val (*        val  num)))))

(define (hue num)
  (hsva-hue-set! color (mod (+ (hsva-hue color) num) 360)))

(define (saturation num)
  (hsva-saturation-set! color ((adjust num) (hsva-saturation color))))

(define (brightness num)
  (hsva-value-set! color ((adjust num) (hsva-value color))))

(define (alpha num)
  (hsva-alpha-set! color ((adjust num) (hsva-alpha color))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define color-stack '())

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (cairo-set-source-rgba cr val)
  (cairo_set_source_rgba cr
                         (rgba-red val)
                         (rgba-green val)
                         (rgba-blue val)
                         (rgba-alpha val)))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(let ((area-width 400)
      (area-height 400))

  (let ((surface (cairo_image_surface_create CAIRO_FORMAT_ARGB32
                                             area-width
                                             area-height)))

    (let ((cr (cairo_create surface)))

      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

      (let ((x-low  -3)
            (x-high  3)
            (y-low  -2)
            (y-high  4))

        (let ((width  (- x-high x-low))
              (height (- y-high y-low)))

          (cairo_scale cr area-width area-height)

          (cairo_scale cr 1 -1)

          (cairo_scale cr (/ 1.0 width) (/ 1.0 height))

          (cairo_translate cr 3 -4)

          ))

      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

      (let ()

        ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

        (define (save)
          (set! color-stack (cons (clone-hsva color) color-stack))
          (cairo_save cr))

        (define (restore)
          (cairo_restore cr)
          (set! color (car color-stack))
          (set! color-stack (cdr color-stack))
          (cairo-set-source-rgba cr (hsva->rgba color)))

        (define (rotate n)
          (cairo_rotate cr (radians n)))

        ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

        (define (circle)
          (cairo-set-source-rgba cr (hsva->rgba color))
          ;; (cairo_arc cr 0.0 0.0 1.0 0 (* 2 M_PI))
          (cairo_arc cr 0.0 0.0 0.5 0 (* 2 M_PI))
          (cairo_fill cr))

        ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

        (define (unit-distance)

          (let ((x (make-c-double 1.0))
                (y (make-c-double 0.0)))

            (cairo_user_to_device_distance cr x y)

            (norm (vector (c-double-ref x)
                          (c-double-ref y)))))

        (define (continue?)

          (> (unit-distance) 1.0)

          ;; (> (unit-distance) 0.5)

          )

        ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

        (define black

          (let ((random-index (lambda () (random-weighted '(60 1))))

                (branch-a

                 (lambda ()

                   (save)
                   (cairo_scale cr 0.6 0.6)
                   (circle)
                   (restore)

                   (save)
                   (cairo_translate cr 0.1 0.0)
                   (rotate 5)
                   (cairo_scale cr 0.99 0.99)
                   (brightness -0.01)
                   (alpha -0.01)
                   (black)
                   (restore)))

                (branch-b

                 (lambda ()

                   (save)
                   (white)
                   (restore)

                   (save)
                   (black)
                   (restore))))

            (let ((branches (vector branch-a branch-b)))

              (lambda ()

                (when (continue?)
                  (let ((branch (vector-ref branches (random-index))))
                    (branch)))

                ))))

        ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

        (define white

          (let ((random-index (lambda () (random-weighted '(60 1))))

                (branch-a

                 (lambda ()

                   (save)
                   (cairo_scale cr 0.6 0.6)
                   (circle)
                   (restore)

                   (save)
                   (cairo_translate cr 0.1 0.0)
                   (rotate -5)
                   (cairo_scale cr 0.99 0.99)
                   (brightness 0.01)
                   (alpha -0.01)
                   (white)
                   (restore)))

                (branch-b

                 (lambda ()

                   (save)
                   (black)
                   (restore)

                   (save)
                   (white)
                   (restore))))

            (let ((branches (vector branch-a branch-b)))

              (lambda ()

                (when (continue?)
                  (let ((branch (vector-ref branches (random-index))))
                    (branch)))

                ))))

        ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

        (define (chiaroscuro)
          (brightness 0.5)
          (black))

        (set! color (make-hsva 0.0 0.0 1.0 1.0))

        (brightness -0.5)

        (cairo-set-source-rgba cr (hsva->rgba color))

        (cairo_rectangle cr -3 -2 6 6)

        (cairo_fill cr)

        (set! color (make-hsva 0.0 0.0 0.0 1.0))

        (cairo-set-source-rgba cr (hsva->rgba color))

        (chiaroscuro)

        )

      ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

      (cairo_destroy cr))

    (cairo_surface_write_to_png surface "chiaroscuro.png")

    (cairo_surface_destroy surface)))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;