;; caleido.scm --- Generate caleidoscope patterns
;;
;; Author: Anders Holst  (aho@sics.se) 
;; Copyright (C) 2002  Anders Holst
;;
;; --------------------------------------------------------------------- 
;;
;; This file tries to generate nice (?) caleidoscope patterns.
;; Use the function  (caleidoscreen)  to set the screen background.
;; To automatically change background every ten minutes do
;;   (require 'timer)


;
;outcome
;((position x . y) (angle . a) (size . r) (form n . f) (color h s i))
;
;distr
;(position xmin ymin xmax ymax)
;(angle)
;(size avg std)
;(form pn avgn pf alfaf)
;(color havg hstd savg sstd iavg istd)
;(mixture (p1 . d1) (p2 . d2) ...)
;(join d1 d2 d3 ...)

(primitive-load-path "demo/timer")

(define (iround x)
  (inexact->exact (round x)))

(define (cal-make-color h s i)
  (let ((r (max 0 (min 1 (/ (- 1 (abs (- (* h 3) 2))) 0.5))))
        (g (max 0 (min 1 (/ (- 1 (abs (- (* h 3) 1))) 0.5))))
        (b (max 0 (min 1 (/ (- (abs (- (* h 3) 1.5)) 0.5) 0.5))))
        (t (* i (- 1 s))))
    (make-color (iround (* 65535 (sqrt (+ t (* s r)))))
                (iround (* 65535 (sqrt (+ t (* s g)))))
                (iround (* 65535 (sqrt (+ t (* s b))))))))

(define (cal-construct-poly x y rad angle num spike)
  (if (= spike 0.0)
      (let* ((tpi (* 8 (atan 1.0)))
             (ang (/ (* tpi angle) 360))
             (astep (/ tpi num))
             (i 0)
             (res '()))
        (while (< i num)
          (set! res (cons (iround (+ y (* rad (sin ang))))
                          (cons (iround (+ x (* rad (cos ang))))
                                res)))
          (set! ang (+ ang astep))
          (set! i (+ 1 i)))
        (reverse! res))
      (let* ((pi (* 4 (atan 1.0)))
             (ang (/ (* pi angle) 180))
             (astep (/ pi num))
             (rad1 (* (+ 1.0 spike) rad))
             (rad2 (* (- 1.0 spike) (cos astep) rad))
             (i 0)
             (res '()))
        (while (< i num)
          (set! res (cons (iround (+ y (* rad1 (sin ang))))
                          (cons (iround (+ x (* rad1 (cos ang))))
                                res)))
          (set! ang (+ ang astep))
          (set! res (cons (iround (+ y (* rad2 (sin ang))))
                          (cons (iround (+ x (* rad2 (cos ang))))
                                res)))
          (set! ang (+ ang astep))
          (set! i (+ 1 i)))
        (reverse! res))))

(define (cal-draw-one-wrap pix descr)
  (let ((dim (cddr (dimensions pix)))
        (pos (assq-ref descr 'position))
        (rad (assq-ref descr 'size))
        (angle (assq-ref descr 'angle))
        (form (assq-ref descr 'form))
        (color (assq-ref descr 'color)))
    (if (= (car form) 0)
        (let ((x (iround (car pos)))
              (y (iround (cdr pos)))
              (r (iround rad))
              (hole (iround (* rad (cdr form))))
              (col (apply cal-make-color color))
              (func #f))
          (if (= hole 0.0)
              (set! func (lambda (xoff yoff)
                           (draw-circle-sector pix (+ xoff x) (+ yoff y) r
                                               :background col)))
              (set! func (lambda (xoff yoff)
                           (draw-circle-sector pix (+ xoff x) (+ yoff y) hole
                                               :borderwidth (- r hole) 
                                               :foreground col))))
          (func 0 0)
          (if (< (- x r) 0) (func (car dim) 0))
          (if (>= (+ x r) (car dim)) (func (- (car dim)) 0))
          (if (< (- y r) 0) (func 0 (cadr dim)))
          (if (>= (+ y r) (cadr dim)) (func 0 (- (cadr dim))))
          (if (and (< (- x r) 0) (< (- y r) 0)) (func (car dim) (cadr dim)))
          (if (and (< (- x r) 0) (>= (+ y r) (cadr dim))) (func (car dim) (- (cadr dim))))
          (if (and (>= (+ x r) (car dim)) (< (- y r) 0)) (func (- (car dim)) (cadr dim)))
          (if (and (>= (+ x r) (car dim)) (>= (+ y r) (cadr dim))) (func (- (car dim)) (- (cadr dim)))))
        (let ((x (iround (car pos)))
              (y (iround (cdr pos)))
              (r (iround (+ rad (* rad (cdr form)))))
              (col (apply cal-make-color color))
              (poly (cal-construct-poly (car pos) (cdr pos) rad angle (car form) (cdr form)))
              (func #f))
          (set! func (lambda (xoff yoff)
                       (let ((flag #f))
                         (apply draw-polygon 
                                (append (list pix) 
                                        (map (lambda (n)
                                               (set! flag (not flag))
                                               (+ n (if flag xoff yoff)))
                                             poly)
                                        (list :color col))))))
          (func 0 0)
          (if (< (- x r) 0) (func (car dim) 0))
          (if (>= (+ x r) (car dim)) (func (- (car dim)) 0))
          (if (< (- y r) 0) (func 0 (cadr dim)))
          (if (>= (+ y r) (cadr dim)) (func 0 (- (cadr dim))))
          (if (and (< (- x r) 0) (< (- y r) 0)) (func (car dim) (cadr dim)))
          (if (and (< (- x r) 0) (>= (+ y r) (cadr dim))) (func (car dim) (- (cadr dim))))
          (if (and (>= (+ x r) (car dim)) (< (- y r) 0)) (func (- (car dim)) (cadr dim)))
          (if (and (>= (+ x r) (car dim)) (>= (+ y r) (cadr dim))) (func (- (car dim)) (- (cadr dim))))))))

(define (cal-draw-one-rotate pix descr sym)
  (let ((dim (cddr (dimensions pix)))
        (pos (assq-ref descr 'position))
        (rad (assq-ref descr 'size))
        (angle (assq-ref descr 'angle))
        (form (assq-ref descr 'form))
        (color (assq-ref descr 'color)))
    (if (= (car form) 0)
        (let ((x (- (car pos) (/ (car dim) 2)))
              (y (- (cdr pos) (/ (cadr dim) 2)))
              (tsin (sin (/ (* 8 (atan 1.0)) sym)))
              (tcos (cos (/ (* 8 (atan 1.0)) sym)))
              (r (iround rad))
              (hole (iround (* rad (cdr form))))
              (col (apply cal-make-color color))
              (func #f)
              (tmp 0.0)
              (i 0))
          (if (= hole 0.0)
              (set! func (lambda (xoff yoff)
                           (draw-circle-sector pix 
                                               (iround (+ xoff (/ (car dim) 2)))
                                               (iround (+ yoff (/ (cadr dim) 2)))
                                               r
                                               :background col)))
              (set! func (lambda (xoff yoff)
                           (draw-circle-sector pix
                                               (iround (+ xoff (/ (car dim) 2)))
                                               (iround (+ yoff (/ (cadr dim) 2)))
                                               hole
                                               :borderwidth (- r hole) 
                                               :foreground col))))
          (while (< i sym)
            (func x y)
            (set! tmp (- (* tcos x) (* tsin y)))
            (set! y (+ (* tsin x) (* tcos y)))
            (set! x tmp)
            (set! i (+ i 1))))
        (let ((x (- (car pos) (/ (car dim) 2)))
              (y (- (cdr pos) (/ (cadr dim) 2)))
              (tsin (sin (/ (* 8 (atan 1.0)) sym)))
              (tcos (cos (/ (* 8 (atan 1.0)) sym)))
              (col (apply cal-make-color color))
              (func #f)
              (tmp 0.0)
              (i 0))
          (set! func (lambda (xoff yoff tang)
                       (apply draw-polygon 
                              (append (list pix) 
                                      (cal-construct-poly (+ xoff (/ (car dim) 2))
                                                          (+ yoff (/ (cadr dim) 2))
                                                          rad tang (car form) (cdr form))
                                        (list :color col)))))
          (while (< i sym)
            (func x y angle)
            (set! angle (+ angle (/ 360.0 sym)))
            (set! tmp (- (* tcos x) (* tsin y)))
            (set! y (+ (* tsin x) (* tcos y)))
            (set! x tmp)
            (set! i (+ i 1)))))))

(define (cal-draw-one-mirror pix descr sym)
  (let ((dim (cddr (dimensions pix)))
        (pos (assq-ref descr 'position))
        (rad (assq-ref descr 'size))
        (angle (assq-ref descr 'angle))
        (form (assq-ref descr 'form))
        (color (assq-ref descr 'color)))
    (if (= (car form) 0)
        (let ((x (- (car pos) (/ (car dim) 2)))
              (y (- (cdr pos) (/ (cadr dim) 2)))
              (tsin (sin (/ (* 8 (atan 1.0)) sym)))
              (tcos (cos (/ (* 8 (atan 1.0)) sym)))
              (r (iround rad))
              (hole (iround (* rad (cdr form))))
              (col (apply cal-make-color color))
              (func #f)
              (tmp 0.0)
              (i 0))
          (if (= hole 0.0)
              (set! func (lambda (xoff yoff)
                           (draw-circle-sector pix 
                                               (iround (+ xoff (/ (car dim) 2)))
                                               (iround (+ yoff (/ (cadr dim) 2)))
                                               r
                                               :background col)))
              (set! func (lambda (xoff yoff)
                           (draw-circle-sector pix
                                               (iround (+ xoff (/ (car dim) 2)))
                                               (iround (+ yoff (/ (cadr dim) 2)))
                                               hole
                                               :borderwidth (- r hole) 
                                               :foreground col))))
          (while (< i sym)
            (func x y)
            (func x (- y))
            (set! tmp (- (* tcos x) (* tsin y)))
            (set! y (+ (* tsin x) (* tcos y)))
            (set! x tmp)
            (set! i (+ i 1))))
        (let ((x (- (car pos) (/ (car dim) 2)))
              (y (- (cdr pos) (/ (cadr dim) 2)))
              (tsin (sin (/ (* 8 (atan 1.0)) sym)))
              (tcos (cos (/ (* 8 (atan 1.0)) sym)))
              (col (apply cal-make-color color))
              (func #f)
              (tmp 0.0)
              (i 0))
          (set! func (lambda (xoff yoff tang)
                       (apply draw-polygon 
                              (append (list pix) 
                                      (cal-construct-poly (+ xoff (/ (car dim) 2))
                                                          (+ yoff (/ (cadr dim) 2))
                                                          rad tang (car form) (cdr form))
                                        (list :color col)))))
          (while (< i sym)
            (func x y angle)
            (func x (- y) (- angle))
            (set! angle (+ angle (/ 360.0 sym)))
            (set! tmp (- (* tcos x) (* tsin y)))
            (set! y (+ (* tsin x) (* tcos y)))
            (set! x tmp)
            (set! i (+ i 1)))))))

(define (cal-generate-descr distr)
  (cond ((eq? (car distr) 'position)
         (list (cons 'position
                     (cons (+ (cadr distr) (random (- (cadddr distr) (cadr distr) -1)))
                           (+ (caddr distr) (random (- (car (cddddr distr)) (caddr distr) -1)))))))
        ((eq? (car distr) 'angle)
         (list (cons 'angle (random 360.0))))
        ((eq? (car distr) 'size)
         (list (cons 'size (max 2 (+ (cadr distr) (* (caddr distr) (random:normal)))))))
        ((eq? (car distr) 'form)
         (let ((circ (< (random 1.0) (cadr distr)))
               (spikes (< (random 1.0) (cadddr distr))))
           (list (cons 'form (cons (if circ 0 (+ 3 (random 6)))
                                   (if spikes (+ 0.2 (* 0.5 (random 1.0))) 0.0))))))
        ((eq? (car distr) 'color)
         (let ((h (+ (cadr distr) (* (caddr distr) (random:normal))))
               (s (+ (cadddr distr) (* (car (cddddr distr)) (random:normal))))
               (i (+ (cadr (cddddr distr)) (* (caddr (cddddr distr)) (random:normal)))))
           (list (list 'color
                       (- h (floor h))
                       (min 1.0 (max 0.0 s))
                       (min 1.0 (max 0.0 i))))))
        ((eq? (car distr) 'mixture)
         (let ((p (random 1.0))
               (acc 0.0)
               (lst (cdr distr)))
           (set! acc (+ acc (caar lst)))
           (while (and (not (null? (cdr lst))) (< acc p))
             (set! lst (cdr lst))
             (set! acc (+ acc (caar lst))))
           (cal-generate-descr (cdar lst))))
        ((pair? (car distr))
         (apply append (map cal-generate-descr distr)))
        (#t '())))

(define (cal-generate-color-distr)
  (let* ((vh (expt (random 0.5) 3))
         (vis (- (/ 0.0027 (+ vh 0.01)) 0.02)))
    (list 'color
          (random 1.0) vh
          (- 1.0 (expt (random 0.8) 3) vis) vis
          (- 1.0 (expt (random 0.8) 3) vis) vis)))

(define (cal-generate-mixture num func)
  (let ((mix (make-list num #f))
        (sum 0.0))
    (set! mix (map (lambda (x)
                     (let ((r (random 1.0)))
                       (set! sum (+ r sum))
                       r))
                   mix))
    (set! mix (map (lambda (x) 
                     (/ x sum))
                   mix))
    (set! mix (map (lambda (x)
                     (cons x (func x)))
                   mix))
    (cons 'mixture mix)))

(define (cal-generate-distr w h)
  (let ((pos (list 'position 0 0 w h))
        (ang '(angle))
        (num (+ 1 (random 3)))
        (mixfunc (lambda (x)
                   (list (list 'size (/ (min w h) (+ (* 10.0 x) 6.0)) 0)
                         (if (> x 0.9)
                             (cal-generate-mixture 2 (lambda (y)
                                                       (list 'form (random 2) #f (random 2) #f)))
                             (list 'form (random 2) #f (random 2) #f))
                         (cal-generate-color-distr)))))
    (list pos ang (cal-generate-mixture num mixfunc))))

(define (cal-draw-forms pix distr num sym)
  (let ((pos (assq-ref distr 'position))
        (color (assq-ref (cal-generate-descr distr) 'color))
        (i 0))
    (draw-rectangle pix (car pos) (cadr pos) (caddr pos) (cadddr pos)
                    :background (cal-make-color (car color)
                                                (max 0.0 (- (cadr color) 0.1))
                                                (min 1.0 (+ (caddr color) 0.1))))
    (while (< i num)
      (cal-draw-one pix (cal-generate-descr distr) sym)
      (set! i (+ 1 i)))))

(define cal-draw-one cal-draw-one-mirror)

(define cal-global-pixmap (make-pixmap (screen-width) (screen-height)))

(define (caleidopix1 pix)
  (let* ((dim (dimensions pix))
         (distr (cal-generate-distr (caddr dim) (cadddr dim)))
         (symetry (+ 3 (random 6))))
    (cal-draw-forms pix distr (iround (/ 200 symetry)) symetry)
    pix))

(define (caleidopix2 w h)
  (let ((pix (make-pixmap w h))
        (distr (cal-generate-distr w h))
        (symetry (+ 3 (random 6))))
    (cal-draw-forms pix distr (iround (/ 200 symetry)) symetry)
    pix))

(define (caleidoscreen)
  (set-deco-background! (screen) (caleidopix1 cal-global-pixmap)))

(define cal-stop-func #f)

(define (start-caleido interval)
  (if cal-stop-func
      (cal-stop-func))
  (set! cal-stop-func (repeated-eval interval caleidoscreen))
  (caleidoscreen))

(define (stop-caleido)
  (if cal-stop-func
      (cal-stop-func)))

