Especificación Técnica: Sistema de Predicción de Desgaste Neumaticos

(defpackage :gp.examples.hilux.neumaticos
  (:use :cl :gp.kernel :gp.simplify-rules)
  (:export #:run #:run-example #:bench))

(in-package :gp.examples.hilux.neumaticos)

;; --- 1. VARIABLES DINÁMICAS (Sensores) ---
(defvar *current-vel* 0.0d0)      ; Velocidad (km/h)
(defvar *current-ay-lat* 0.0d0)   ; G-Lateral
(defvar *current-fz-load* 0.0d0)  ; Carga (1.0=Vacío, 2.0=Lleno)
(defvar *current-temp-amb* 0.0d0) ; Temperatura ambiente
(defvar *current-hum-amb* 0.0d0)  ; Humedad
(defvar *current-suelo-k* 1.0d0)  ; 1.0=Asfalto, 4.0=Ripio

(defvar *hilux-fitness-cases* nil)

;; --- 2. ARITMÉTICA PROTEGIDA (Anti-Complejos y Anti-Explosiones) ---

(defun % (a b)
  "División protegida."
  (if (and (numberp b) (/= b 0))
      (/ a b)
      0.0d0))

(defun safe-log (a)
  "Logaritmo protegido para evitar números complejos (usa valor absoluto)."
  (let ((abs-a (abs (float a 0.0d0))))
    (if (< abs-a 1.0d-6) -6.0d0 (log abs-a))))

(defun safe-exp (a)
  "Exponencial protegida para evitar overflows."
  (let ((val (float a 0.0d0)))
    (exp (max -20.0d0 (min 20.0d0 val)))))

(defun safe-expt (base power)
  "Potencia protegida: evita bases negativas (complejos) y potencias gigantes."
  (let ((b (abs (float base 0.0d0)))
        (p (max -10.0d0 (min 10.0d0 (float power 0.0d0)))))
    (handler-case (expt b p)
      (error () 0.0d0))))

(defun if-gt (a b then else)
  "Si A > B devuelve THEN, si no ELSE. Versión funcional para GP."
  (if (> a b) then else))

(defun sqr (x) (* x x))

;; --- 3. CONFIGURACIÓN GP ---

(defun define-function-set-for-HILUX ()
  ;; Añadimos MIN y ABS explícito para que pueda "recortar" picos de desgaste
  (values '(+ - * % safe-exp safe-log max min safe-expt if-gt abs sqr) 
          '(2 2 2 2 1 1 2 2 2 4 1 1)))


(defun generate-constants (n range)
  "Genera N constantes aleatorias para darle variedad al set inicial."
  (loop repeat n collect (float (- (random (* 2.0 range)) range) 0.0d0)))

(defun define-terminal-set-for-HILUX ()
  (values (append '(*current-vel* *current-ay-lat* *current-fz-load* *current-temp-amb* *current-hum-amb* *current-suelo-k*)
                  '(0.1 1.0 10.0) ; Constantes fijas estructurales
                  (generate-constants 5 100.0)) ; 5 constantes aleatorias entre -100 y 100
          nil))


(defun generate-hilux-fitness-cases ()
  "Casos testigo de la Patagonia Norte (Target en Micrones/km)."
  (setf *hilux-fitness-cases*
        '(;; --- CASOS ORIGINALES ---
          (100.0  0.05  1.0  25.0  40.0  1.0   0.15)  ; 1. Crucero Asfalto
          (60.0   0.45  1.2  38.0  20.0  1.0   0.85)  ; 2. Verano curvas
          (40.0   0.20  1.0   5.0  80.0  4.0   1.20)  ; 3. Ripio Invierno
          (30.0   0.30  2.0  15.0  50.0  4.0   2.50)  ; 4. Carga máxima ripio
          (80.0   0.80  1.0  30.0  30.0  1.0   5.00)  ; 5. Frenada brusca
          (20.0   0.10  1.0  10.0  90.0  2.0   0.10)  ; 6. Ciudad lluvia
          ;; 7. Ripio consolidado alta velocidad (Ruta 40 - Chipping)
          (70.0   0.15  1.1  18.0  35.0  3.5   0.90)  
          ;; 8. Barro/Nieve (Paso Pino Hachado - Mucho torque/poco avance)
          (15.0   0.05  1.5  -2.0  95.0  4.5   0.40)  
          ;; 9. Asfalto abrasivo con carga media (Subida a yacimiento)
          (50.0   0.25  1.6  32.0  15.0  1.5   0.65)  
          ;; 10. Ralentí / Maniobras en base (Cero desgaste térmico)
          (5.0    0.05  1.0  20.0  50.0  2.0   0.02)  
          ;; 11. Crucero en ripio seco (Norte de Neuquén - Enero)
          (65.0   0.10  1.0  35.0  10.0  4.0   1.45)  
          ;; 12. Descenso de montaña trabado (Uso intenso de freno/lateral)
          (45.0   0.60  1.4  22.0  40.0  1.2   1.10)
          ;; 13. Ruta con viento lateral fuerte (Compensación de dirección)
          (110.0  0.15  1.0  12.0  60.0  1.0   0.35)))

  (setf *number-of-fitness-cases* (length *hilux-fitness-cases*))
  *hilux-fitness-cases*)



;; --- 4. MOTOR DE EVALUACIÓN (Fitness) ---
(defun evaluate-standardized-fitness-for-HILUX (program fitness-cases)
  (let ((error-total 0.0d0)
        (hits 0)
        (tree-size (count-nodes program))
        (symbols '(*current-vel* *current-ay-lat* *current-fz-load* *current-temp-amb* *current-hum-amb* *current-suelo-k*)))
    (dolist (case fitness-cases)
      (let* ((values (mapcar (lambda (x) (float x 0.0d0)) (subseq case 0 6)))
             (target (seventh case))
             ;; CASOS CRÍTICOS: Peso doble si es frío extremo (< 5°C) o ripio pesado (k > 3.5)
             (weight (if (or (< (fourth case) 5.0) (> (sixth case) 3.5)) 2.0d0 1.0d0)))

        (progv symbols values
          (let ((pred (handler-case 
                          (sb-int:with-float-traps-masked (:overflow :invalid :divide-by-zero)
                            (eval program))
                        (error () :error))))

            (cond 
              ((or (eq pred :error) (not (numberp pred)) (complexp pred)
                   (sb-ext:float-infinity-p pred) (sb-ext:float-nan-p pred))
               (incf error-total 5000.0d0))

              (t
               (let* ((diff (abs (- (float (realpart pred) 0.0d0) target)))
                      ;; Penalización cuadrática ponderada por la importancia del caso
                      (weighted-diff (* weight 
                                        (cond ((< diff 1.0) diff)
                                              ((> diff 1.0d100) 1.0d200)
                                              (t (expt diff 2))))))
                 (incf error-total weighted-diff)
                 (if (< diff 0.1) (incf hits)))))))))

    ;; Parsimony Pressure aumentada para evitar el bloat y mejorar generalización
    (let ((final-fitness (+ error-total (* tree-size 0.005d0))))
      (values (float final-fitness 0.0d0) hits))))


(defun count-nodes (tree)
  "Retorna el número total de nodos en el árbol (S-Expression)."
  (if (listp tree)
      (1+ (reduce #'+ (mapcar #'count-nodes (cdr tree)) :initial-value 0))
      1))


;; --- 5. PARÁMETROS DEL SISTEMA ---
(defun define-parameters-for-HILUX ()
  (setf *number-of-fitness-cases* (length (generate-hilux-fitness-cases)))
  (setf *rules* *boolean-rules*)
  ;; Aumentamos un poco la profundidad permitida para dar margen de maniobra
  (setf *max-depth-for-new-individuals* 6) 
  (setf *max-depth-for-new-subtrees-in-mutants* 4)
  (setf *max-depth-for-individuals-after-crossover* 15)
  ;; Mantenemos las proporciones de cruce
  (setf *fitness-proportionate-reproduction-fraction* 0.1)
  (setf *crossover-at-any-point-fraction* 0.2)
  (setf *crossover-at-function-point-fraction* 0.5)
  (setf *method-of-selection* :tournament)
  (setf *method-of-generation* :ramped-half-and-half)
  (values))


(defun define-termination-criterion-for-HILUX (gen max-gen best-fit best-hits)
  (declare (ignore best-fit))
  (or (>= gen max-gen)
      (>= best-hits *number-of-fitness-cases*)))

(defun HILUX-NEUMATICOS ()
  (values 'define-function-set-for-HILUX
          'define-terminal-set-for-HILUX
          'generate-hilux-fitness-cases
          'evaluate-standardized-fitness-for-HILUX
          'define-parameters-for-HILUX
          'define-termination-criterion-for-HILUX))

;; --- 6. EJECUCIÓN ---

(defun run (maximum-generations size-of-population seed 
            &key (verbose nil) 
              (filename "/home/mtk/quicklisp/local-projects/gp/examples/hilux_neumaticos_results.txt"))
  (let ((*verbose* (if verbose :verbose :silent)))
    (with-open-file (*standard-output* filename :direction :output 
                                                :if-exists :supersede :if-does-not-exist :create)
      (format t "--- INICIANDO EVOLUCION: DESGASTE NEUMATICOS HILUX ---~%")
      (gp.kernel:run-genetic-programming-system 'HILUX-NEUMATICOS seed maximum-generations size-of-population)
      (format t "~%--- FIN DEL RUN ---~%"))
    (format t "Proceso finalizado. Resultados en: ~A~%" filename)
    (values)))

(defun bench ()
  (format t "~%--- BENCHMARK NEUMATICOS ---~%")
  (generate-hilux-fitness-cases)
  (time (run 600 15000 777 :verbose nil)))