#lang racket/base

; Dependencies
(require
  racket/list
  "element.rkt"
  "../../base-generation/random.rkt"
  "../../base-generation/distribution.rkt")

; Export
(provide
  ; Construction of affinity
  make-affinity
  combine-affinity
  ; To display
  affinity-composition
  affinity-non-reduced-composition
  ; Signed elements
  signed-element-name
  signed-element-sign
  signed-element-count
  )

; Affinity structure
(struct affinity
  (genes ; List of exact primary signed elements, used for computing genetic transmission
   non-reduced-composition ; Sorted list of signed elements, with count computed
   composition)) ; Combined composition, with secondary and tertiary elements

; Signed elements
; Structure used in composition of affinity
(struct signed-element
  (name
   sign
   count))

; Number of genes in the list
(define nb-genes 100)

; Construction of affinity from a distribution of element names
; Note: the distribution must contains only primary and secondary elements
(define (make-affinity elements elem-dist)
  (define nb-elements 4)
  (define nb-occurences 13)
  (define (random:signed-element elem) (signed-element elem (string-append (if (random:boolean) "+" "-") (substring elem 0 1)) 1))
  (define genes
    (take
      (shuffle
        (apply
          append
          (build-list
            nb-elements
            (lambda (_)
              (define el (elements-ref elements (distribution-generate elem-dist)))
              (if (combined-element? el)
                  (flatten
                    (make-list
                      nb-occurences
                      (map
                        random:signed-element
                        (combined-element-components el))))
                  (make-list (* 2 nb-occurences) (random:signed-element (element-name el)))
                  )))))
      nb-genes))
  (define non-reduced-composition (compute-composition genes))
  (affinity
    genes
    non-reduced-composition
    (reduce-composition elements non-reduced-composition)))

; Construction of affinity from two affinities
(define (combine-affinity elements aff1 aff2)
  (define genes
    (take
      (shuffle
        (append
          (affinity-genes aff1)
          (affinity-genes aff2)))
       nb-genes))
  (define non-reduced-composition (compute-composition genes))
  (affinity
    genes
    non-reduced-composition
    (reduce-composition elements non-reduced-composition)))

; Reduce the genes to a list of genes with occurence count
(define (compute-composition genes)
  (define table (make-hash))
  (for-each
    (lambda (x)
      (define cell (cons (signed-element-name x) (signed-element-sign x)))
      (if (hash-has-key? table cell)
          (hash-set! table cell (+ 1 (hash-ref table cell)))
          (hash-set! table cell 1)))
    genes)
  (sort-composition
    (hash-map
      table
      (lambda (k v)
        (signed-element
          (car k)
          (cdr k)
          v)))))

; Sort and remove the element with null count
(define (sort-composition comp)
  (sort
    (filter
      (lambda (x) (> (signed-element-count x) 0))
      comp)
    (lambda (x y) (> (signed-element-count x) (signed-element-count y)))))


; Return the combination, or #f if it doesn't exist
; Combination will combine the signs in the order of the combination table.
(define (combine-element elements a b)
  (define combination-table (elements-combination-table elements))
  (cond
    ((hash-has-key? combination-table (list (signed-element-name a) (signed-element-name b)))
     (signed-element
        (hash-ref combination-table (list (signed-element-name a) (signed-element-name b)))
        (string-append (signed-element-sign a) "/" (signed-element-sign b))
        1))
    ((hash-has-key? combination-table (list (signed-element-name b) (signed-element-name a)))
     (signed-element
       (hash-ref combination-table (list (signed-element-name b) (signed-element-name a)))
       (string-append (signed-element-sign b) "/" (signed-element-sign a))
       1))
    (#t #f)))

; Combine the composition
; Algo: if the rest of the input list is not null:
; Consider the two first elements of the input list
; if combination is possible:
;  - combine the elements:
;    * with elements A, B, of occurence count cA, cB (cA >= cB):
;    * replace in the list the items [(A, c1), (B, cB)] by:
;      + if A and B are both primary or secondary: [(AB, cB+cB), (A, cA-cB)]
;      + if A is primary and B secondary: [(AB, cB+cB/2), (A, cA-cB/2)]
;      + if A is secondary and B primary, and cB <= cA/2: [(AB, 3*cB), (A, cA-2*cB)]
;      + if A is secondary and B primary, and cB > cA/2: [(AB, cA+cA/2), (B, cB-cA/2)]
;  - sort the list
; else:
;  - remove the first element from the input list and put it in the result list
; Repeat
(define (reduce-composition elements comp [result (list)])
  (define (compute-replacement A B AB)
    (let ((A-secondary? (combined-element? (elements-ref elements (signed-element-name A))))
          (B-secondary? (combined-element? (elements-ref elements (signed-element-name B))))
          (cA (signed-element-count A))
          (cB (signed-element-count B))
          )
      (cond
        ( (eq? A-secondary? B-secondary?)
          (list
            (signed-element (signed-element-name AB) (signed-element-sign AB) (+ cB cB))
            (signed-element (signed-element-name A) (signed-element-sign A) (- cA cB))))
        ( B-secondary?
          (list
            (signed-element (signed-element-name AB) (signed-element-sign AB) (+ cB (floor (/ cB 2))))
            (signed-element (signed-element-name A) (signed-element-sign A) (- cA (floor (/ cB 2))))))
        ( (<= cB (/ cA 2))
          (list
            (signed-element (signed-element-name AB) (signed-element-sign AB) (+ cB cB cB))
            (signed-element (signed-element-name A) (signed-element-sign A) (- cA cB cB))))
        ( #t
          (list
            (signed-element (signed-element-name AB) (signed-element-sign AB) (+ cA (floor (/ cA 2))))
            (signed-element (signed-element-name B) (signed-element-sign B) (- cB (floor (/ cA 2))))))
        )))
  (cond
    ((null? comp)
     (sort-composition result))
    ((null? (cdr comp))
     (reduce-composition elements (list) (append comp result)))
    (#t
      (let*  ((a (car comp))
              (b (cadr comp))
              (c (combine-element elements a b)))
        (if c
            (reduce-composition
              elements
              (sort-composition
                (append (compute-replacement a b c) (cddr comp)))
              result)
            (reduce-composition
              elements
              (cdr comp)
              (cons (car comp) result))
            )))))
