#lang scheme
;; generates code to generate patterns

(require "gp.ss")
(require "range.ss")
(provide (all-defined-out))

; safe versions of functions we will use to build
; genetic code - won't fall over with odd parameters

(define (mod a b)
  (if (zero? (round b)) 
      0
      (modulo (inexact->exact (round a))
              (inexact->exact (round b)))))

(define (safediv . args)
  (foldl
   (lambda (arg r)
     (if (zero? arg) 0 (/ r arg)))
   0
   args))

(define (odd n)
  (if (odd? (inexact->exact (round n))) 1 0))

(define (even n)
  (if (even? (inexact->exact (round n))) 1 0))

(define (less a b)
  (if (< a b) 1 0))

(define (greater a b)
  (if (> a b) 1 0))

(define (if-num q a b)
  (if (not (zero? q)) a b))

(define current-clock 0)

(define (clock) current-clock)

(define dict (list 
              (make-dict-fn mod (range 2 2))
              (make-dict-fn odd (range 1 1))
              (make-dict-fn even (range 1 1))
              ;(make-dict-fn if-num (range 3 3))
              ;(make-dict-fn less (range 2 2))
              ;(make-dict-fn greater (range 2 2))
              (make-dict-fn min (range 2 2))
              (make-dict-fn max (range 2 2))
              (make-dict-fn clock (range 0 0))
              (make-dict-fn * (range 1 'unbounded))
              (make-dict-fn safediv (range 1 'unbounded))
              (make-dict-fn + (range 1 'unbounded))
              (make-dict-fn - (range 1 'unbounded))
              ;(make-dict-fn sin (range 1 1))
              ;(make-dict-fn cos (range 1 1))
              ))

(define ns (make-base-namespace))

(define (build-pattern size p)
  #;(printf "building: ~a~n" p)
  (build-list size
              (lambda (clock)
                (set! current-clock clock)
                (eval p ns))))

(define (same? pattern)
  (cdr
   (foldl
    (lambda (v r)
      (if (not (eq? v (car r))) 
          (cons v #f) r))
    (cons (car pattern) #t)
    pattern)))

(define (deriv l)
  (map - l (cons 0 (trunc l (- (length l) 1)))))

(define (diff a b)
  (define (sq n) (* n n))
  (sq (foldl
   (lambda (a b r)
      (+ r (abs (- a b))))
   0 a b ;(deriv a) (deriv b)
   )))


(define (pattern-fitness program target)
;  (pretty-print-program program)(newline)
  (let ((pattern (build-pattern (length target) program)))
    (+ (if (list? program)
           (let ((d (* 10 (get-max-depth program))))
             (* d d)) ;shorter programs are fitter
           0)                      
       (if #f #;(same? pattern) 9999999999
           (diff target pattern)))))