(define number-of-input-values 16)
(define population-size 1000)

(define number-of-random-vectors 1000) ;;calculate the fitness for `number-of-random-vectors vectors
(define tournament-league-size (round (* population-size 0.1)))
(define functions-depth 5)
(define pr 0.1)
(define pm 0.01)
(define pc 0.89)
(define pa 0)

(define run (lambda() (load "evolution-ex3.scm")))

(define counters (make-vector 10 0))

(define check-time
  (lambda(index proc)
    (lambda lst
      (let ((start (current-milliseconds))
            (output (apply proc lst)))
        (vector-set! counters index (+ (vector-ref counters index) (- (current-milliseconds) start)))
        output))))


(define make-normal
  (lambda(x avg delta)
    (let ((t (min delta (abs (- avg x)))))
      (* 0.99 (/ t delta)))))


;;replaces all but one. with random (create&swap! i j)
(define search&replace-all-but-one
  (lambda(search-what lst)
    (let ((first? #t))
      (letrec ((search&replace
                (lambda(search-what lst)
                  (cond 
                    ((equal? search-what lst) (if first? (begin (set! first? #f) lst) (^function 1)))
                    ((pair? lst) `(,(search&replace search-what  (car lst)) .
                                    ,(search&replace search-what  (cdr lst))))
                    (else lst)))))
        (search&replace search-what lst)))))


(define divide
  (lambda(lst ret)
    (if (null? lst) 
        (ret '() '())
        (with lst
              (lambda(first . rest)
                (divide (if (null? rest) () (cddr lst))
                        (lambda(lst1 lst2)
                          (ret (cons first lst1)
                               (if (null? rest) lst2 (cons (car rest) lst2))))))))))

(define ^merge-sort
  (lambda(op<)
    (letrec ((merge-sort
              (lambda(lst)
                (letrec ((merge (lambda(lst1 lst2)
                                  (if (or (null? lst1) (null? lst2)) (append lst1 lst2)
                                      (if (op< (car lst1) (car lst2)) 
                                          `(,(car lst1) . ,(merge (cdr lst1) lst2))
                                          `(,(car lst2) . ,(merge lst1 (cdr lst2))))))))
                  
                  (if (or (null? lst) (null? (cdr lst))) lst
                      (divide lst 
                              (lambda(lst1 lst2)
                                (merge (merge-sort lst1) (merge-sort lst2)))))))))
      merge-sort)))


(define collect-c&s
  (lambda(func)
    (cond ((and (pair? func) (eq? (car func) 'compare&swap!)) (list (cdr func)))
          ((pair? func) `(,@(collect-c&s (car func)) ,@(collect-c&s (cdr func))))
          (else '()))))


(define remove-duplications 
  (lambda(func)
    (letrec (
             (sort (^merge-sort (lambda(x y)
                                  (with x (lambda(majorx minorx)
                                            (with y (lambda(majory minory)
                                                      (if (= majorx majory)
                                                          (< minorx minory)
                                                          (< majorx majory)))))))))
             (remove-single (lambda(lst last first?)   ;;@@pre the list is sorted. @post only duplicates
                              (let ((eq-lst-last (and (pair? lst) (equal? (car lst) last))))
                                (cond ((null? lst) '())
                                      ((and (pair? lst) first? eq-lst-last )
                                       `(,(car lst) ,@(remove-single (cdr lst) (car lst) #f)))
                                      (else (remove-single (cdr lst) (car lst) (not eq-lst-last)))))))
             (loop (lambda(dup-list func)
                     (if (null? dup-list)
                         func
                         (search&replace-all-but-one `(compare&swap! ,@(car dup-list)) 
                                                     (loop (cdr dup-list) func))))))
      
      
      
      (loop (remove-single (sort (collect-c&s func)) #f #t) func))))


(define compare&swap!
  (lambda(myVec i j)
    (let ((first  (vector-ref myVec i))
          (second (vector-ref myVec j)))
      (if (> first second)
          (begin
            (vector-set! myVec i second)
            (vector-set! myVec j first))))))

(define ^list
  (lambda(from to)
    (if (> from to) 
        '()
        `(,from . ,(^list (add1 from) to)))))

(define make-list-from-lambda
  (lambda(proc size)
    (if (> size 0)
        `(,(proc) . ,(make-list-from-lambda proc (sub1 size)))
        '())))


(define functions '((nop 0 all)
                    (compare&swap! 2 only-terminals) 
                    (prog2 2 only-functions) 
                    (prog3 3 only-functions) 
                    (prog4 4 only-functions)))

(define terminals (^list 0 (sub1 number-of-input-values)))

(define with (lambda(lst proc) (apply proc lst)))

(define ^function-by-number
  (lambda(func-number depth)
    (let* ((func-number (if (eq? 'rand func-number) (random (length functions)) func-number))
           (func (list-ref functions func-number)))
      (with func
            (lambda(func-name number-of-arguments type)
              (let* ((^arg 
                      (lambda()
                        (cond ((eq? type 'all)
                               (if (zero? (random 2))
                                   (^function (sub1 depth))
                                   (^terminal)))
                              ((eq? type 'only-terminals)
                               (^terminal))
                              ((eq? type 'only-functions)
                               (^function (sub1 depth))))))
                     (args (make-list-from-lambda ^arg number-of-arguments)))
                `(,func-name ,@args)))))))


(define ^function 
  (lambda(depth)
    (if (zero? depth) 
        (^function-by-number (random 2) 99)
        (^function-by-number 'rand depth)
        )))

(define ^terminal
  (lambda()
    (list-ref terminals (random (length terminals)))))

(define run-func!
  (check-time 1
              (lambda(vec func)
                (let ((compare&swap! 
                       (lambda(i j)
                         (compare&swap! vec i j)))
                      (prog2 (lambda(a b) (void)))
                      (prog3 (lambda(a b c) (void)))
                      (prog4 (lambda(a b c d) (void)))
                      (nop void))
                  ((eval `(lambda ,(map car functions) ,func))
                   nop
                   compare&swap!
                   prog2
                   prog3
                   prog4
                   )))))

(define run-ccs!
  (check-time 2
              (lambda(vec css)
                (map (lambda(x) (apply compare&swap! vec x)) css))))


(define make-vector
  (lambda(size value)
    (list->vector (make-list-from-lambda (lambda() value) size))))

(define vector-copy!
  (lambda(source dest)
    (letrec ((loop (lambda(i)
                     (if (>= i 0)
                         (begin
                           (vector-set! dest i (vector-ref source i))
                           (loop (sub1 i)))
                         dest))))
      (loop (sub1 (vector-length source))))))

(define vector-accumulate
  (lambda(init proc vec)
    (letrec ((loop (lambda(i)
                     (if (>= i 0)
                         (proc (vector-ref vec i) (loop (sub1 i)))
                         init))))
      (loop (sub1 (vector-length vec))))))

(define vector-set-range!
  (lambda(vec from to value)
    (letrec ((loop (lambda(from)
                     (if (< from to)
                         (begin
                           (vector-set! vec from value)
                           (loop (add1 from)))
                         vec))))
      (loop from))))

(define vector-map!
  (lambda(proc vec)
    (letrec ((loop (lambda(index)
                     (if (< index (vector-length vec))
                         (begin
                           (vector-set! vec index (proc (vector-ref vec index)))
                           (loop (add1 index)))
                         vec))))
      (loop 0))))


(define make-sorted-vector
  (lambda(source dest)
    (let ((index-of-first1 (- (vector-length source) (vector-accumulate 0 + source))))
      (vector-set-range! dest 0 index-of-first1 0)
      (vector-set-range! dest index-of-first1 (vector-length source) 1)
      dest)))

(define count-compare-exchange
  (lambda(func)
    (cond ((null? func) 0 )
          ((pair? func) (+ (count-compare-exchange (car func)) (count-compare-exchange (cdr func))))
          ((eq? func 'compare&swap!) 1)
          (else 0))))

(define run-prefix!
  (lambda(vec)
    (let ((prefix '((0 1) (2 3) (4 5) (6 7) (8 9) (10 11) (12 13) (14 15) 
                          (0 2) (4 6) (8 10) (12 14) 
                          (1 3) (5 7) (9 11) (13 15)
                          (0 4) (8 12)
                          (1 5) (9 13)
                          (2 6) (10 14)
                          (3 7) (11 15)
                          (0 8)
                          (1 9)
                          (2 10)
                          (3 11)
                          (4 12)
                          (5 13)
                          (6 14)
                          (7 15))))
      (letrec ((loop (lambda(lst)
                       (if (not (null? lst) )
                           (begin
                             ;                             (display (car lst)) (newline)
                             (apply compare&swap! vec (car lst))
                             (loop (cdr lst)))))))
        (loop prefix)))))



(define fitness
  (check-time 0 
              (lambda(func)
                (let (
                      ; check all possible configurations            
                      ;          (^test-vec
                      ;           (let* ((vec-size number-of-input-values)
                      ;                  (vec (make-vector vec-size 0))) 
                      ;             (lambda(ret-vec done)
                      ;               (letrec ((loop (lambda(index) 
                      ;                                (if (< index vec-size)
                      ;                                    (if (= (vector-ref vec index) 0) 
                      ;                                        (begin (vector-set! vec index 1) (ret-vec vec))
                      ;                                        (begin (vector-set! vec index 0) (loop (add1 index)) ))
                      ;                                    (done)))))
                      ;                 (loop 0)))))
                      
                      ; test number-of-random-vectors randomly generated vectors
                      (^test-vec 
                       (let* ((vec-size number-of-input-values)
                              (vec (make-vector vec-size 0))
                              (number-of-random-vectors number-of-random-vectors))
                         (lambda(ret-vec done)
                           (if (zero? number-of-random-vectors) (done) 
                               (begin
                                 (vector-map! (lambda(x) (random 2)) vec)
                                 (set! number-of-random-vectors (sub1 number-of-random-vectors))
                                 (ret-vec vec))))))
                      
                      (test-vec 
                       (let ((temp-vec (make-vector number-of-input-values 0))
                             (temp-vec2 (make-vector number-of-input-values 0))
                             (opt-func (collect-c&s func)))
                         (lambda(vec)
                           ;                 (display vec)                                
                           (let* ((vec (vector-copy! vec temp-vec2))
                                  (expected (make-sorted-vector vec temp-vec)))
                             ;                 (display vec)
                             (run-prefix! vec)
                             (run-ccs! vec opt-func)
                             ;                 (display " ==> ")
                             ;                 (display vec)
                             ;                 (newline)
                             
                             (if (equal? expected vec) 0 1))))))
                  (letrec ((loop 
                            (lambda() 
                              (^test-vec 
                               (lambda(vec)
                                 ;                       (display vec)
                                 (+ (test-vec vec) (loop)))
                               (lambda() (make-normal (count-compare-exchange func) 28 40))))));;;;;for make-norma
                    (loop )  )))))


(define slow-fitness
  (lambda(func)
    (let (
          ; check all possible configurations            
          (^test-vec
           (let* ((vec-size number-of-input-values)
                  (vec (make-vector vec-size 0))) 
             (lambda(ret-vec done)
               (letrec ((loop (lambda(index) 
                                (if (< index vec-size)
                                    (if (= (vector-ref vec index) 0) 
                                        (begin (vector-set! vec index 1) (ret-vec vec))
                                        (begin (vector-set! vec index 0) (loop (add1 index)) ))
                                    (done)))))
                 (loop 0)))))
          
          (test-vec 
           (let ((temp-vec (make-vector number-of-input-values 0))
                 (temp-vec2 (make-vector number-of-input-values 0)))
             (lambda(vec)
               ;                 (display vec)                                
               (let* ((vec (vector-copy! vec temp-vec2))
                      (expected (make-sorted-vector vec temp-vec)))
                 ;                 (display vec)
                 (run-prefix! vec)
                 (run-func! vec func)
                 ;                 (display " ==> ")
                 ;                 (display vec)
                 ;                 (newline)
                 
                 (if (equal? expected vec) 0 1))))))
      (letrec ((loop 
                (lambda() 
                  (^test-vec 
                   (lambda(vec)
                     ;                       (display vec)
                     (+ (test-vec vec) (loop)))
                   (lambda() (make-normal (count-compare-exchange func) 28 20))))))
        (loop )  ))))



(define generation0
  (lambda(depth-limit)
    (let ((generation (make-vector population-size depth-limit)))
      (vector-map! ^function generation)
      ;      (vector-map! remove-duplications generation)
      )))

(define fitness-generation
  (lambda(generation)
    (let ((fitness-vec (make-vector population-size 0)))
      (vector-copy! generation fitness-vec)
      (vector-map! fitness fitness-vec))))


(define make-buble-sort 
  (lambda()
    (letrec ((loopi
              (lambda(i proc)
                (if (< i (sub1 number-of-input-values))
                    `(prog2 ,(proc i) ,(loopi (add1 i) proc))
                    'nop))))
      (loopi 0 (lambda(j)
                 (loopi 0 (lambda(i) `(compare&swap! ,i ,(add1 i)))))))))

(define count-func
  (lambda(func ret-functions-terminals)
    (cond ((null? func) (ret-functions-terminals 0 0))
          ((pair? func) 
           (count-func (car func)
                       (lambda(ret-car-functions ret-car-terminals)
                         (count-func (cdr func)
                                     (lambda(ret-cdr-functions ret-cdr-terminals)
                                       (ret-functions-terminals (+ ret-car-functions ret-cdr-functions)
                                                                (+ ret-car-terminals ret-cdr-terminals)))))))
          ((memq func terminals) (ret-functions-terminals 0 1))
          ((memq func (map car functions)) (ret-functions-terminals 1 0))
          (else (error "unknown symbol" func)))))


(define get-sub-func
  (lambda(func index)
    (letrec ((loop 
              (lambda(func i)
                (cond ((null? func) i)
                      ((and (pair? func) (symbol? (car func)))
                       (if (= i index)
                           func
                           (loop (cdr func) (add1 i))))
                      ((pair? func) 
                       (let ((loop-car (loop (car func) i)))
                         (if (number? loop-car)
                             (loop (cdr func) loop-car)
                             loop-car)))
                      (else i)))))
      (let ((ret (loop func 0)))
        (if (number? ret)
            (error "index out of range")
            ret)))))




(define replace-function
  (lambda(func index sub-tree)
    (letrec ((loop 
              (lambda(func i ret-i-func)
                (cond ((null? func) (ret-i-func i '()))
                      ((and (pair? func) (symbol? (car func)))
                       (if (= i index)
                           (ret-i-func (add1 i) sub-tree)
                           (loop (cdr func) (add1 i)
                                 (lambda(ret-cdr-i ret-cdr-func)
                                   (ret-i-func ret-cdr-i
                                               (cons
                                                (car func)
                                                ret-cdr-func))))))
                      ((pair? func) 
                       (loop (car func) i 
                             (lambda(ret-car-i ret-car-func)
                               (loop (cdr func) ret-car-i
                                     (lambda(ret-cdr-i ret-cdr-func)
                                       (ret-i-func ret-cdr-i (cons ret-car-func ret-cdr-func)))))))
                      
                      
                      (else (ret-i-func i func))))))
      (loop func 0 (lambda(x y) y)))))
;                (cond ((null? func) '())
;                      ((pair? func)
;                       (if (= i index)
;                           sub-tree
;                           `(,(loop (car func) (add1 i)) . ,(loop (cdr func) (add1 i))))
;                       `(,(loop (car func) i) . ,(loop (cdr func) i))))
;                (else func)))))
;    (loop func 0)))



(define tournament
  (lambda(generation generation-fitness k)
    (let ((next-generation (make-vector population-size '()))
          (cPr pr)
          (cPc (+ pr pc))
          (cPm (+ pr pc pm))
          (cPa (+ pr pc pm pa)))
      (letrec ((find-min-k 
                (lambda(i ret-min-index-fitness)
                  (if (< i k )
                      (let* ((cur-index (random population-size)) 
                             (cur-fitness (vector-ref generation-fitness cur-index)))
                        (find-min-k (add1 i)
                                    (lambda(ret-index ret-fitness)
                                      (let ((new-min (min cur-fitness ret-fitness)))
                                        (ret-min-index-fitness (if (= cur-fitness new-min) cur-index ret-index) new-min)))))
                      (ret-min-index-fitness 0 100000)))))
        (letrec ((loop 
                  (lambda(i)
                    (if (< i population-size)
                        (find-min-k 0 (lambda(index fitness)
                                        ;                                        (vector-set! next-generation i (vector-ref generation index))
                                        (let ((rnd (random))
                                              (winner (vector-ref generation index)))
                                          (cond 
                                            ;;reproduction
                                            ((< rnd cPr) (vector-set! next-generation i winner)
                                                         (loop (add1 i)))
                                            ;;xo
                                            ((< rnd cPc) 
                                             (find-min-k 0 
                                                         (lambda(mom-index mom-fitness)
                                                           (let* ((winner-dad winner)
                                                                  (winner-mom (vector-ref generation index))
                                                                  (rnd-index-dad (random (count-func winner-dad (lambda(x y) x))))
                                                                  (rnd-index-mom (random (count-func winner-mom (lambda(x y) x)))))
                                                             (vector-set! next-generation i 
                                                                          (remove-duplications 
                                                                           (replace-function winner-dad rnd-index-dad 
                                                                                             (get-sub-func winner-mom rnd-index-mom))))
                                                             (if (< (add1 i) population-size)
                                                                 (vector-set! next-generation (add1 i) 
                                                                              (remove-duplications
                                                                               (replace-function winner-mom rnd-index-mom
                                                                                                 (get-sub-func winner-dad rnd-index-dad))))))))
                                             (loop (+ i 2)))
                                            ;;mutation
                                            ((< rnd cPm) 
                                             (vector-set! next-generation i
                                                          (replace-function winner (random (count-func winner (lambda(x y) x))) (^function 5)))
                                             (loop (add1 i)))
                                            ;;algorithm specific
                                            ((< rnd cPa) (void)))
                                          
                                          
                                          
                                          )))
                        next-generation))))
          (loop 0)
          next-generation)))))



(define vector-find
  (lambda(vec value)
    (letrec ((loop (lambda(i)
                     (if (or (eq? (vector-ref vec i) value) (= (vector-ref vec i) value))
                         i
                         (loop (add1 i))))))
      (loop 0))))

(define print-fitness 
  (lambda(fit generation-vec number-of-generation number-of-generations port-txt port-csv)
    (let* ((fit-lst (vector->list fit))
           (min-fit (apply min fit-lst))
           (avg-fit (/ (apply + fit-lst) (vector-length fit)))
           (min-func (vector-ref generation-vec (vector-find fit min-fit))))
      (display ".")
      (display (format 
                "#~a: ~a,  ~a --> ~a \n \n" 
                (- number-of-generations number-of-generation)
                min-fit
                (count-compare-exchange min-func)
                min-func) port-txt)
      (display (format
                "~a,~a,~a,~a\n"
                (- number-of-generations number-of-generation)
                min-fit
                avg-fit
                (count-compare-exchange min-func)) port-csv))))

(define go
  (lambda(number-of-generations)
    (let ((file-name (symbol->string (gensym 'output-run))))
      (display file-name)
      (newline)
      (call-with-output-file (string-append file-name ".txt")
        (lambda(port-txt)
          (call-with-output-file (string-append file-name ".csv")
            (lambda(port-csv)
              (display "Generation,minimum,average,#compare&swap\n" port-csv)
              (letrec ((loop 
                        (lambda(number-of-generation generation-vec)
                          (if (zero? number-of-generation) 
                              generation-vec
                              (let ((fit (fitness-generation generation-vec)))
                                (print-fitness fit generation-vec number-of-generation number-of-generations port-txt port-csv)
                                (loop (sub1 number-of-generation)
                                      (tournament generation-vec fit tournament-league-size)))))))
                (loop number-of-generations (generation0 functions-depth))))))))))