;;; -*-LISP-*-
;;;
;;; Copyright (C) 2005 Donald Fisk
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
;;; USA

;;; BUG!!! colors can take any values, including uninitialized objects
;;; whose printing can cause segmentation faults.

(defclass MandelCanvas (Canvas)
  (a type Real accessor getA initForm -2.0)
  (b type Real accessor getB initForm -1.25)
  (scale type Real accessor getScale initForm 2.5)
  (cutoff type Int accessor getCutoff initForm 50)
  (zoom type Real accessor getZoom initForm 2.0)
  (shades type Array accessor getShades))

  
(defmethod (setf getCutoff) after ((newCutoff Int) (mc MandelCanvas))
  ;; Recompute shades.
  (do ((i 0 (add1 i))
       (shades (makeVector (add1 newCutoff) _)))
      ((> i newCutoff)
       (setf (getShades mc) shades))
      (setf (aref shades i) (dwellColor (/ i newCutoff 1.0)))))

(defun dwellColor (x)
  (cond ((>= x 1.0)
	 BLACK)
	((and (> 1.0 x) (>= x 0.666667))
	 (findColor (/ (+ (* x 3) 1) 4) (- (* x 3) 2) 0.0))
	((and (> 0.666667 x) (>= x 0.333333))
	 (findColor (/ (+ (* x 3) 1) 4) 0.0 (/ (- 2 (* x 3)) 2)))
	(TRUE
	 (findColor (/ (* x 3) 2) 0.0 (/ (+ (* x 3) 1) 4)))))

(defmethod initializeInstance after ((mc MandelCanvas) (initialArgs AList))
  (let* ((win (getWindow mc))
	 (gc (getGC mc))
	 (a (getA mc))
	 (b (getB mc))
	 (cutoff (getCutoff mc))
	 (size (getWidth mc))
	 (incr (/ (getScale mc) (getWidth mc)))
	 (endX (+ (getA mc) (getScale mc)))
	 (endY (+ (getB mc) (getScale mc)))
	 (shades (makeVector (add1 cutoff) _)))
    ;; Precompute shades.
    (do ((i 0 (add1 i)))
	((> i cutoff))
	(setf (aref shades i) (dwellColor (/ i cutoff 1.0))))
    (setf (getShades mc) shades)
    (debug 'init a b (getScale mc) cutoff size incr)
    (do ((x 0 (add1 x)))
	((= x size))
	(do ((y 0 (add1 y)))
	    ((= y size))
	    (drawPoint win gc x y
		       (aref shades (dwell (+ a (* x incr))
					   (+ b (* y incr))
					   cutoff)))))))

(defmethod whenLeftClickEvent ((mc MandelCanvas) (event Array))
  (let ((win (getWindow mc))
	(gc (getGC mc))
	(cutoff (getCutoff mc))
	(size (getWidth mc))
	(incr (/ (getScale mc) (getWidth mc)))) ;OLD incr
    (setf (getScale mc) (/ (getScale mc) (getZoom mc)))
    (setf (getA mc)
	  (+ (getA mc)
	     (* (eventX event) incr) ;OLD incr
	     (* (getScale mc) -0.5))) ; NEW scale / 2 = old scale / 4
    (setf (getB mc)
	  (+ (getB mc)
	     (* (eventY event) incr) ;OLD incr
	     (* (getScale mc) -0.5))) ; NEW scale / 2 = old scale / 4
    (setf incr (/ incr (getZoom mc)))
    (let* ((a (getA mc))
	   (b (getB mc))
	   (endX (+ (getA mc) (getScale mc)))
	   (endY (+ (getB mc) (getScale mc)))
	   (shades (getShades mc)))
      (debug 'click a b (getScale mc) cutoff size incr)
      (do ((x 0 (add1 x)))
	  ((= x size))
	  (do ((y 0 (add1 y)))
	      ((= y size))
	      (drawPoint win gc x y
			 (aref shades (dwell (+ a (* x incr))
					     (+ b (* y incr))
					     cutoff))))))))

(defun dwell (a b cutoff)
  (do ((i 0 (add1 i))
       (x a)
       (y b)
       (newX))
      ((or (>= i cutoff) (>= (+ (* x x) (* y y)) 4.0))
       i)
      (setf newX (+ a (* x x) (- (* y y))))
      (setf y (+ b (* 2 x y)))
      (setf x newX)))

(defun zoom (size mag cutoff)
  (new 'MandelCanvas 'width size 'height size 'zoom mag 'cutoff cutoff)
  0)

;; (zoom 600 10.0 100)
;; (progn (setf mc (new 'MandelCanvas 'width 400 'height 400 'zoom 10.0 'cutoff 100)) 0)