(require :asdf)

(pushnew #P"/usr/local/asdf-install/site-systems/" asdf:*central-registry*)

(defpackage #:approx-ft-about
  (:use "COMMON-LISP"))
(in-package #:approx-ft-about)

(defun make-image-from-params ( params buf ww hh )
  (labels ((clip (vv)
	     (declare (type fixnum vv))
	     (cond
	       ((minusp vv) 0)
	       ((< 255 vv) 255)
	       (t vv)))
	   (calc (ii jj params &optional (sum 0.5d0))
	     (declare (type double-float ii jj)
		      (type list params)
		      (optimize (speed 3)))
	     (cond
	       ((null params) (clip (round (* sum 255.0d0))))
	       (t (let ((pp (first params)))
		    (let ((amp (first pp))
			  (freq (second pp))
			  (angle (third pp))
			  (off (fourth pp)))
		      (declare (type double-float amp freq angle off))
		      (let ((cos (coerce (cos angle) 'double-float))
			    (sin (coerce (sin angle) 'double-float)))
			(declare (type double-float cos sin))
			(let ((xx (+ (* cos ii) (* sin jj))))
			  (declare (type double-float xx))
			  (let ((raw (coerce (cos (* 2.0d0 pi
						     (+ (* xx freq) off)))
					     'double-float)))
			    (declare (type double-float raw))
			    (calc ii jj
				  (rest params)
				  (+ (* amp raw) sum)))))))))))
    (loop :for jj :from 0 :below hh
       :do (loop :with fj = (- (/ jj hh 0.5d0) 1.0d0)
	      :for ii :from 0 :below ww
	      :do (loop :with fi = (- (/ ii ww 0.5d0) 1.0d0)
		     :for kk :from 0 :below 1
		     :do (setf (aref buf (+ (* jj ww) ii))
			       (calc fi fj params)))))
    buf))

(defun make-image ( amp freq angle off buf ww hh )
  (declare (type double-float amp freq angle off))
  (make-image-from-params (list (list amp freq angle off)) buf ww hh))

(defun make-angle-cycler (initial step buf ww hh
			  &key (amp 0.5d0)
			       (freq 3.0d0)
			       (off 0.0d0))
  (let ((angle (coerce initial 'double-float)))
    (lambda ()
      (values
         (make-image amp freq angle off buf ww hh)
	 (incf angle step)))))

(defun make-offset-cycler (initial step buf ww hh
			  &key (amp 0.5d0)
			       (freq 3.0d0)
			       (angle 0.0d0))
  (let ((off (coerce initial 'double-float)))
    (lambda ()
      (values
         (make-image amp freq angle off buf ww hh)
	 (incf off step)))))

(defun make-frequency-cycler (scale step buf ww hh
			      &key (amp 0.5d0)
			           (angle 0.0d0)
			           (off 0.0d0))
  (let ((freq-angle 0.0d0))
    (lambda ()
      (values
         (make-image amp (* (cos freq-angle) scale) angle off buf ww hh)
	 (incf freq-angle step)))))

(defun make-amplitude-cycler (scale step buf ww hh
			      &key (freq 0.5d0)
			           (angle 0.0d0)
			           (off 0.0d0))
  (let ((amp-angle 0.0d0))
    (lambda ()
      (values
         (make-image (* (cos amp-angle) scale)
		     freq angle off buf ww hh)
	 (incf amp-angle step)))))

(defun make-list-cycler (params buf ww hh)
  (let ((cur (1- (length params))))
    (lambda ()
      (let ((pp (nthcdr cur params)))
	(when (plusp cur)
	  (decf cur))
	(make-image-from-params pp buf ww hh)))))

(defun fixed-to-float ( ff )
  (/ (- ff 32768) 1024.0))

(defparameter +param-count+ 4)
(defparameter +scale+ 0.02d0)
(defparameter +wave-scale+ 1.5d0)

(defun load-gene ( pathname )
  (let ((raw (with-open-file (in pathname)
	       (read in)))
	(scale (make-array +param-count+
			   :initial-contents (list +scale+
						   +wave-scale+
						   pi
						   +wave-scale+))))
    (loop :for ii :from 0 :below (length raw) :by +param-count+
       :collecting (loop :for jj :from 0 :below +param-count+
		      :collecting (* (fixed-to-float (aref raw (+ ii jj)))
				     (aref scale jj))))))

(defparameter +waves+ (load-gene "gene.lisp"))