;;; Scheme Recursive Art Contest Entry
;;;
;;; Please do not include your name or personal info in this file.
;;;
;;; Title: I made a thing
;;;
;;; Description:
;;;    Oh no I dropped all
;;;    my crayons in a blender
;;;    but I made a thing

; So this is an incredibly slow fractal flame generator
; and there are a bunch of additions like log-density histogram coloration
; and some other lame stuff
; It didn't make it into the final version because it takes a million years to render
; so a lot of this code is extraneous and commented out as needed

; Some credit to the program Apophysis ( http://apophysis.org/ ) which generated the fractal I was modeling after
; and Scott Draves and Erik Reckase for writing this fancy PDF ( http://flam3.com/flame.pdf )
; that this algorithm hails from

; Also thanks to Scheme for being a massive pain in the

(define number-of-dots 100000)

(define (caar lst)
        (car (car lst)))

(define (cadr lst)
        (car (cdr lst)))

(define (caddr lst)
        (cadr (cdr lst)))

(define (cadddr lst)
        (caddr (cdr lst)))

(define (caddddr lst)
        (cadddr (cdr lst)))

(define (cadddddr lst)
        (caddddr (cdr lst)))

(define (map2 fn lst result)
    (if (null? lst)
        result
        (map2 fn (cdr lst) (append result (list (fn (car lst)))))))
(define (map fn lst) (map2 fn lst nil))

(define (min a b)
    (if (< a b) a b)
)

; Gradient (time b g r)

(define gradient
    '(
    (0 72 148 90)
    (30 56 40 9)
    (61 42 5 73)
    (91 105 61 29)
    (120 33 45 104)
    (150 96 14 18)
    (180 30 143 128)
    (210 19 28 193)
    (241 69 3 18)
    (271 129 34 89)
    (300 21 70 226)
    (330 39 180 194)
    (360 36 6 64)
    (390 63 95 87)
    (401 73 128 64)
    )
)

(define (getlowcolors c prev lst)
    (if (< (* c 400) (caar lst))
        prev
        (getlowcolors c (car lst) (cdr lst))))

(define (gethighcolors c lst)
    (if (< (* c 400) (caar lst))
        (car lst)
        (gethighcolors c (cdr lst))))

(define (getcolor c)
    (let ((low (getlowcolors c nil gradient)) (high (gethighcolors c gradient)))
         (let
            ((lt (car low))
             (ht (car high))
             (lr (cadddr low))
             (hr (cadddr high))
             (lg (caddr low))
             (hg (caddr high))
             (lb (cadr low))
             (hb (cadr high)))
         (let
            ((interp (/ (- (* c 400) lt) (- ht lt))))
            (list (/ (+ (* interp (- hr lr)) lr) 255)
                  (/ (+ (* interp (- hg lg)) lg) 255)
                  (/ (+ (* interp (- hb lb)) lb) 255)
)))))

; Triangle: (transform rotate scale color)

(define trianglelist 
    '(
;    ((0 0) 0 (0.5 0.5) 0)
;    ((0.5 0) 0 (0.5 0.5) 0)
;    ((0 0.5) 1.5707963267948966192313216916398 (0.5 0.5) 0)
     ((-0.086824 0.492404) 2.6179938779914943653855361527329 (0.828535 0.828535) 0)
     ((-0.09721 -0.359677) -0.29851238861485015918914345058845 (0.722768 0.722768) 0.5)
     ((0.745943 -0.396373) 0 (0.2 0.2) 1)
    )
)
(define (gettri n)
    (define (tri m trilist)
        (if (> m 0)
            (tri (- m 1) (cdr trilist))
            (car trilist)))
    (tri n trianglelist)
)

(define l 200)

(define (count-pos2 x lst total)
    (if (null? lst)
        total
        (if (and (equal? (car x) (caar lst)) (equal? (cadr x) (cadr (car lst))))
            (count-pos2 x (cdr lst) (+ total 1))
            (count-pos2 x (cdr lst) total))))
(define (count-pos x lst) (count-pos2 x lst 0))

(define (dots n x y c lst)
    (if (= n 0)
        lst
        (let ((tri (gettri (randint 0 2))))
          (let ((sx (* x (car (caddr tri))))
                (sy (* y (cadr (caddr tri))))
                (r (cadr tri)))
          (let ((rx (- (* sx (cos r)) (* sy (sin r))))
                (ry (+ (* sx (sin r)) (* sy (cos r)))))
          (let ((nx (+ rx (caar tri)))
                (ny (+ ry (cadr (car tri))))
                (nc (/ (+ c (cadddr tri)) 2)))
               (dots (- n 1) nx ny nc (append lst (list (list (floor (* l nx)) (floor (* l ny)) nc))))))))))

(define (remove-all-pos2 x lst newlst)
  (if (null? lst)
      newlst
      (if (and (equal? (car x) (caar lst)) (equal? (cadr x) (cadr (car lst))))
          (remove-all-pos2 x (cdr lst) newlst)
          (remove-all-pos2 x (cdr lst) (append newlst (list (car lst))))
)))
(define (remove-all-pos x lst) (remove-all-pos2 x lst nil))

(define (sumrgb-pos2 x lst newr newg newb) ; haha, newb
  (if (null? lst)
      (list (car x) (cadr x) newr newg newb)
      (if (and (equal? (car x) (caar lst)) (equal? (cadr x) (cadr (car lst))))
          (sumrgb-pos2 x (cdr lst) (+ newr (caddr (car lst))) (+ newg (cadddr (car lst))) (+ newb (caddddr (car lst))))
          (sumrgb-pos2 x (cdr lst) newr newg newb)
)))
(define (sumrgb-pos x lst) (sumrgb-pos2 x lst 0 0 0))

; Dots (x y c)
; Dotscount (x y c n sumRGB)

; alldotsraw ((x y c))
(define alldotsraw (dots number-of-dots 0 0 0 nil))

; DotsRGB (x y r g b)
(define (dot-rawtorgb d)
  (let ((c (getcolor (caddr d))))
    (let ((r (car c))
          (g (cadr c))
          (b (caddr c)))
         (list (car d) (cadr d) r g b)
)))

(define alldotsrgb (map dot-rawtorgb alldotsraw))

; DotsRGBCount (x y sumR sumG sumB n)
(define (dotscount2 rgbdotslst newlst)
  (if (null? rgbdotslst)
      newlst
      (let ((currentdot (car rgbdotslst)))
           (let ((dotcount (count-pos currentdot rgbdotslst))
                 (cleanlst (remove-all-pos currentdot rgbdotslst))
                 (sumrgbdot (sumrgb-pos currentdot rgbdotslst)))
                 (dotscount2 cleanlst (append newlst (list (append sumrgbdot (list dotcount))))))
)))
(define (dotscount dotslst) (dotscount2 dotslst nil))

; (define alldotsrgbc (dotscount alldotsrgb))

; DotsRGBCavg (x y r g b n)
; is this code unreadable yet?
(define (dot-rgbctorgbcavg d)
    (let ((cnt (cadddddr d)))
         (list (car d) (cadr d) (/ (caddr d) cnt) (/ (cadddr d) cnt) (/ (caddddr d) cnt) cnt)))

; (define alldotsrgbcavg (map dot-rgbctorgbcavg alldotsrgbc))

; DotsRGBadj
(define (maxcount2 dotscountlst m)
    (if (null? dotscountlst)
        m
        (if (> (cadddddr (car dotscountlst)) m)
            (maxcount2 (cdr dotscountlst) (cadddddr (car dotscountlst)))
            (maxcount2 (cdr dotscountlst) m)
)))
(define (maxcount dotscountlst) (maxcount2 dotscountlst 0))

; (define maxn (maxcount alldotsrgbcavg))

; how about now?
; 5 is artificial brightness factor
(define (dot-rgbcavgtorgbcadj d)
    (let ((brightness (* (/ (exp (cadddddr d)) (exp maxn)) 5)))
         (list (car d) (cadr d)
            (min (* brightness (caddr d)) 1)
            (min (* brightness (cadddr d)) 1)
            (min (* brightness (caddddr d)) 1))
))

; (define alldotsrgbadj (map dot-rgbcavgtorgbcadj alldotsrgbcavg))

; Color (r g b)
; Final dot (x y r g b)

(define (drawdot p)
    (and
    (penup)
    (color2 (list (caddr p) (cadddr p) (caddddr p)))
    (setpos (car p) (cadr p))
    (pendown)
    (dot 2)
    true)
)

(define (draw)
  (speed 0)
  (dot 1000)
  (delay 0)
  (map drawdot alldotsrgb)
  (exitonclick))

; Please leave this last line alone.  You may add additional procedures above
; this line.  All Scheme tokens in this file (including the one below) count
; toward the token limit.
(draw)