;;; -*- mode: Lisp; Syntax: Common-Lisp; -*-
;;;
;;; Copyright (c) 2009 by the authors.
;;;
;;; See LICENCE for details.

(in-package :hu.dwim.genetic-programming.test)

;;;;;;
;;; Suite

(def structure eurusd-data
  (open nil :type double-float)
  (low nil :type double-float)
  (high nil :type double-float)
  (close nil :type double-float))

(def constant +average-period+ 1000)

(def special-variable *eurusd-index*)

(def special-variable +eurusd-data+ (with-open-file (input-stream (system-relative-pathname :hu.dwim.genetic-programming "test/EURUSD.csv"))
                                      (iter (for line = (read-line input-stream nil :eof))
                                            (until (eq line :eof))
                                            (when (starts-with-subseq ";" line) ;
                                              (next-iteration))
                                            (for pieces = (cl-ppcre:split "," line :limit most-positive-fixnum))
                                            (collect (flet ((parse (string)
                                                              (coerce (parse-number:parse-number string) 'double-float)))
                                                       (make-eurusd-data :open (parse (elt pieces 3))
                                                                         :low (parse (elt pieces 4))
                                                                         :high (parse (elt pieces 5))
                                                                         :close (parse (elt pieces 6))))
                                              :result-type 'vector))))

(def function compute-eurusd-close-min ()
  (iter (for index :from *eurusd-index* :downto (max 0 (- *eurusd-index* +average-period+)))
        (minimizing (eurusd-data-close (elt +eurusd-data+ index)))))

(def function compute-eurusd-close-max ()
  (iter (for index :from *eurusd-index* :downto (max 0 (- *eurusd-index* +average-period+)))
        (maximizing (eurusd-data-close (elt +eurusd-data+ index)))))

(def function compute-eurusd-close-average ()
  (iter (for index :from *eurusd-index* :downto (max 0 (- *eurusd-index* +average-period+)))
        (for count :from 1)
        (summing (eurusd-data-close (elt +eurusd-data+ index)) :into sum)
        (finally (return (/ sum count)))))

(def special-variable +eurusd-close-min+ (iter (for *eurusd-index* :from 0 :below (length +eurusd-data+))
                                                   (collect (compute-eurusd-close-min) :result-type 'vector)))

(def special-variable +eurusd-close-max+ (iter (for *eurusd-index* :from 0 :below (length +eurusd-data+))
                                                   (collect (compute-eurusd-close-max) :result-type 'vector)))

(def special-variable +eurusd-close-average+ (iter (for *eurusd-index* :from 0 :below (length +eurusd-data+))
                                                   (collect (compute-eurusd-close-average) :result-type 'vector)))

(def function eurusd-close-min ()
  (elt +eurusd-close-min+ *eurusd-index*))

(def function-descriptor eurusd-close-min () number)

(def function eurusd-previous-close-min ()
  (elt +eurusd-close-min+ (max 0 (- *eurusd-index* +average-period+))))

(def function-descriptor eurusd-previous-close-min () number)

(def function eurusd-close-max ()
  (elt +eurusd-close-max+ *eurusd-index*))

(def function-descriptor eurusd-close-max () number)

(def function eurusd-previous-close-max ()
  (elt +eurusd-close-max+ (max 0 (- *eurusd-index* +average-period+))))

(def function-descriptor eurusd-previous-close-max () number)

(def function eurusd-close-average ()
  (elt +eurusd-close-average+ *eurusd-index*))

(def function-descriptor eurusd-close-average () number)

(def function eurusd-previous-close-average ()
  (elt +eurusd-close-average+ (max 0 (- *eurusd-index* +average-period+))))

(def function-descriptor eurusd-previous-close-average () number)

(def function compute-eurusd-fitness-1 (individual)
  (iter (with initial-eur = 1000)
        (with initial-usd = 0)
        (with exchange-cost-rate = 0.001)
        (with pi-half = (/ pi 2))
        (with current-eur = initial-eur)
        (with current-usd = initial-usd)
        (with compiled-form = (hu.dwim.genetic-programming::ensure-individual-compiled-form individual))
        (for index :from 0)
        (for eurusd-data :in-sequence +eurusd-data+)
        (for eurusd-rate = (eurusd-data-close eurusd-data))
        (for position = (min (max (/ (atan (bind ((*eurusd-index* index))
                                             (funcall compiled-form)))
                                     pi-half)
                                  -1)
                             1))
        (for eur-weight = (abs (- 1 position)))
        (for usd-weight = (abs (- -1 position)))
        (for total-weight = (+ eur-weight usd-weight))
        (for current-total-eur = (+ current-eur (/ current-usd eurusd-rate)))
        (for next-usd = (* (* current-total-eur (/ usd-weight total-weight)) eurusd-rate))
        (for next-eur = (* current-total-eur (/ eur-weight total-weight)))
        (setf current-usd next-usd)
        (setf current-eur (- next-eur (* exchange-cost-rate (abs (- next-eur current-eur)))))
        (finally (return current-total-eur))))

(def function compute-eurusd-fitness-2 (individual)
  (iter (with initial-eur = 1000)
        (with initial-usd = 0)
        (with exchange-cost-rate = 0.001)
        (with current-eur = initial-eur)
        (with current-usd = initial-usd)
        (with compiled-form = (hu.dwim.genetic-programming::ensure-individual-compiled-form individual))
        (for index :from 0)
        (for eurusd-data :in-sequence +eurusd-data+)
        (for eurusd-rate = (eurusd-data-close eurusd-data))
        (for position = (bind ((*eurusd-index* index))
                          (funcall compiled-form)))
        (for eur-weight = (if (< position 0) 1 0))
        (for usd-weight = (if (>= position 0) 1 0))
        (for total-weight = (+ eur-weight usd-weight))
        (for current-total-eur = (+ current-eur (/ current-usd eurusd-rate)))
        (for next-usd = (* (* current-total-eur (/ usd-weight total-weight)) eurusd-rate))
        (for next-eur = (* current-total-eur (/ eur-weight total-weight)))
        (setf current-usd next-usd)
        (setf current-eur (- next-eur (* exchange-cost-rate (abs (- next-eur current-eur)))))
        (finally (return current-total-eur))))

(def function compute-eurusd-fitness-3 (individual)
  (iter (with initial-eur = 1000)
        (with initial-usd = 0)
        (with exchange-cost-rate = 0.001)
        (with current-eur = initial-eur)
        (with current-usd = initial-usd)
        (with compiled-form = (hu.dwim.genetic-programming::ensure-individual-compiled-form individual))
        (for index :from 0)
        (for eurusd-data :in-sequence +eurusd-data+)
        (for eurusd-rate = (eurusd-data-close eurusd-data))
        (for position = (bind ((*eurusd-index* index))
                          (funcall compiled-form)))
        (for eur-weight = (if position 1 0))
        (for usd-weight = (if (not position) 1 0))
        (for total-weight = (+ eur-weight usd-weight))
        (for current-total-eur = (+ current-eur (/ current-usd eurusd-rate)))
        (for next-usd = (* (* current-total-eur (/ usd-weight total-weight)) eurusd-rate))
        (for next-eur = (* current-total-eur (/ eur-weight total-weight)))
        (setf current-usd next-usd)
        (setf current-eur (- next-eur (* exchange-cost-rate (abs (- next-eur current-eur)))))
        (finally (return current-total-eur))))

(def test test/eurusd (&key (max-population 100) (max-generation 10000))
  (population-best-individual
   (evolve :initial-population-generator (lambda ()
                                           (make-random-population :individual-count max-population
                                                                   :lambda-form-generator (lambda ()
                                                                                            (generate-lambda-form :generator (make-generator)
                                                                                                                  :return-type 'boolean
                                                                                                                  :maximum-depth 3))))
           :evolution-termination-predicate (lambda (population)
                                              (= (hu.dwim.genetic-programming::population-generation population) max-generation))
           :fitness-calculator 'compute-eurusd-fitness-3
           :fitness-sort-predicate #'>
           :population-printer 'print-best-individual
           :survivor-selector (lambda (population)
                                (bind ((individuals (hu.dwim.genetic-programming::population-individuals population)))
                                  (sort individuals #'> :key (lambda (individual)
                                                               (if (hu.dwim.genetic-programming::individual-erroneous individual)
                                                                   0
                                                                   (hu.dwim.genetic-programming::individual-fitness individual))))
                                  (subseq individuals 0 max-population)))
           :reproduction-function (lambda (population)
                                    (reproduce-individuals population (floor (/ max-population 10))
                                                           :weight-calculator (lambda (individual)
                                                                                (if (hu.dwim.genetic-programming::individual-erroneous individual)
                                                                                    0
                                                                                    (hu.dwim.genetic-programming::individual-fitness individual))))))))