(vl-load-com)

;;;=====================================================================
;;; XFondo v4
;;; Comandos publicos:
;;;   XFONDO       - alterna entre los fondos configurados
;;;   XFONDOCONFIG - configura un fondo oscuro y uno claro
;;;
;;; Requiere Visual LISP/ActiveX. Las propiedades opcionales se detectan
;;; en tiempo de ejecucion para mejorar la compatibilidad entre CAD.
;;;=====================================================================

(defun xfondo:rgb-to-ole (rgb)
  (+ (car rgb) (* (cadr rgb) 256) (* (caddr rgb) 65536))
)

(defun xfondo:rgb-to-string (rgb)
  (strcat (itoa (car rgb)) "," (itoa (cadr rgb)) "," (itoa (caddr rgb)))
)

(defun xfondo:valid-component-p (value)
  (and (numberp value)
       (= value (fix value))
       (<= 0 value)
       (<= value 255))
)

(defun xfondo:digits-only-p (text / index code valid)
  (setq index 1
        valid (and text (> (strlen text) 0)))
  (while (and valid (<= index (strlen text)))
    (setq code (ascii (substr text index 1)))
    (if (or (< code 48) (> code 57))
      (setq valid nil))
    (setq index (1+ index))
  )
  valid
)

(defun xfondo:parse-component (text / clean value)
  (setq clean (vl-string-trim " \t" text))
  (if (xfondo:digits-only-p clean)
    (progn
      (setq value (atoi clean))
      (if (xfondo:valid-component-p value) value)
    )
  )
)

(defun xfondo:parse-rgb (text / first second tail red green blue)
  ;; Formato admitido: R,G,B, con espacios opcionales.
  (if text
    (progn
      (setq first (vl-string-search "," text))
      (if first
        (progn
          (setq tail (substr text (+ first 2))
                second (vl-string-search "," tail))
          (if (and second
                   (null (vl-string-search "," (substr tail (+ second 2)))))
            (progn
              (setq red   (xfondo:parse-component (substr text 1 first))
                    green (xfondo:parse-component (substr tail 1 second))
                    blue  (xfondo:parse-component (substr tail (+ second 2))))
              (if (and red green blue) (list red green blue))
            )
          )
        )
      )
    )
  )
)

(defun xfondo:get-custom-rgb (kind / text rgb done)
  (setq done nil)
  (while (not done)
    (setq text
      (getstring T
        (strcat "\nColor " kind " en formato R,G,B (ej. 127,127,127) <Cancelar>: ")))
    (cond
      ((= text "")
        (setq done T rgb nil))
      ((setq rgb (xfondo:parse-rgb text))
        (setq done T))
      (T
        (prompt "\nRGB invalido. Use tres enteros entre 0 y 255 separados por comas."))
    )
  )
  rgb
)

(defun xfondo:choose-dark ( / choice)
  (initget "Default Gris Negro Personalizado")
  (setq choice
    (getkword
      "\nDefina el fondo oscuro [Default/Gris/Negro/Personalizado] <Default>: "))
  (if (null choice) (setq choice "Default"))
  (cond
    ((= choice "Default") '(33 40 48))
    ((= choice "Gris") '(105 105 105))
    ((= choice "Negro") '(0 0 0))
    ((= choice "Personalizado") (xfondo:get-custom-rgb "oscuro"))
  )
)

(defun xfondo:choose-light ( / choice)
  (initget "Blanco Personalizado")
  (setq choice
    (getkword
      "\nDefina el fondo claro [Blanco/Personalizado] <Blanco>: "))
  (if (null choice) (setq choice "Blanco"))
  (cond
    ((= choice "Blanco") '(255 255 255))
    ((= choice "Personalizado") (xfondo:get-custom-rgb "claro"))
  )
)

(defun xfondo:save-config (dark light / result)
  ;; Una sola entrada hace que el guardado de la pareja sea atomico.
  ;; setenv persiste en el perfil de la aplicacion CAD.
  (setq result
    (vl-catch-all-apply
      'setenv
      (list
        "XFONDO_CONFIG"
        (strcat (xfondo:rgb-to-string dark)
                "|"
                (xfondo:rgb-to-string light)))))
  (and (not (vl-catch-all-error-p result))
       (equal (list dark light) (xfondo:load-config)))
)

(defun xfondo:load-config ( / text separator dark light)
  (setq text (getenv "XFONDO_CONFIG"))
  (if text
    (progn
      (setq separator (vl-string-search "|" text))
      (if (and separator
               (null (vl-string-search "|" (substr text (+ separator 2)))))
        (progn
          (setq dark (xfondo:parse-rgb (substr text 1 separator))
                light (xfondo:parse-rgb (substr text (+ separator 2))))
          (if (and dark light (not (equal dark light)))
            (list dark light))
        )
      )
    )
  )
)

(defun xfondo:get-display-impl ( / app preferences)
  (setq app (vlax-get-acad-object)
        preferences (vla-get-Preferences app))
  (vla-get-Display preferences)
)

(defun xfondo:get-display ( / result)
  (setq result (vl-catch-all-apply 'xfondo:get-display-impl '()))
  (if (vl-catch-all-error-p result) nil result)
)

(defun xfondo:property-available-p (object property write-p / result)
  (setq result
    (vl-catch-all-apply
      'vlax-property-available-p
      (list object property write-p)))
  (and (not (vl-catch-all-error-p result)) result)
)

(defun xfondo:ole-color-to-long (value / converted raw)
  ;; AutoCAD expone OLE_COLOR como subtipo COM 19, que no siempre puede
  ;; convertirse directamente a un valor Lisp. La conversion explicita a
  ;; vbLong evita el error "LispFromPtr failed".
  (setq converted (vlax-variant-change-type value vlax-vbLong)
        raw (vlax-variant-value converted))
  (if (numberp raw) (fix raw))
)

(defun xfondo:get-color-property-impl (object property / value)
  (setq value
    (cond
      ((= property 'GraphicsWinModelBackgrndColor)
        (vla-get-GraphicsWinModelBackgrndColor object))
      ((= property 'GraphicsWinLayoutBackgrndColor)
        (vla-get-GraphicsWinLayoutBackgrndColor object))
      ((= property 'ModelCrosshairColor)
        (vla-get-ModelCrosshairColor object))
    ))
  (if value (xfondo:ole-color-to-long value))
)

(defun xfondo:get-color-property (object property / result)
  (if (xfondo:property-available-p object property nil)
    (progn
      (setq result
        (vl-catch-all-apply
          'xfondo:get-color-property-impl
          (list object property)))
      (if (vl-catch-all-error-p result)
        nil
        result)
    )
  )
)

(defun xfondo:put-color-property (object property value / result)
  (if (xfondo:property-available-p object property T)
    (progn
      (setq result
        (vl-catch-all-apply
          'vlax-put-property
          (list object property value)))
      (not (vl-catch-all-error-p result))
    )
    nil
  )
)

(defun xfondo:set-ui-theme (value / result)
  ;; COLORTHEME puede no existir en algun CAD compatible.
  (setq result (vl-catch-all-apply 'setvar (list "COLORTHEME" value)))
  (not (vl-catch-all-error-p result))
)

(defun xfondo:contrast-color (rgb)
  (if (> (+ (* 0.299 (car rgb))
            (* 0.587 (cadr rgb))
            (* 0.114 (caddr rgb)))
         128.0)
    0
    16777215)
)

(defun xfondo:active-space ()
  ;; La pestaña decide el comportamiento: en cualquier Presentacion se
  ;; cambia solamente el fondo de Papel y nunca el tema de interfaz, incluso
  ;; si hay una ventana grafica activa. Solo la pestaña Modelo cambia el tema.
  (if (= (getvar "TILEMODE") 0) 'PAPER 'MODEL)
)

(defun xfondo:choose-target ( / choice)
  (initget 1 "Oscuro Claro")
  (setq choice
    (getkword
      "\nEl fondo actual no coincide con la configuracion. Elija [Oscuro/Claro]: "))
  (if (= choice "Oscuro") 'DARK 'LIGHT)
)

(defun xfondo:regen ()
  ;; Esta estrategia se conserva de la variante probada para ZWCAD.
  ;; COMMAND es una forma especial en ZWCAD y no puede pasarse como argumento
  ;; a vl-catch-all-apply (produce "bad order function: COMMAND").
  (command "_.REGENALL")
  (princ)
)

(defun c:XFONDOCONFIG ( / *error* dark light)
  (defun *error* (message)
    (if (and message
             (/= message "Function cancelled")
             (/= message "quit / exit abort"))
      (prompt (strcat "\nError en XFondoConfig: " message)))
    (princ)
  )

  (prompt "\nConfiguracion de XFondo. Los cambios se guardan al completar ambos colores.")
  (setq dark (xfondo:choose-dark))
  (if dark
    (setq light (xfondo:choose-light)))

  (cond
    ((or (null dark) (null light))
      (prompt "\nConfiguracion cancelada; no se modificaron los colores guardados."))
    ((equal dark light)
      (prompt "\nLos fondos oscuro y claro no pueden ser iguales; no se guardaron cambios."))
    ((xfondo:save-config dark light)
      (prompt
        (strcat
          "\nXFondo configurado. Oscuro: " (xfondo:rgb-to-string dark)
          " | Claro: " (xfondo:rgb-to-string light) ".")))
    (T
      (prompt "\nNo se pudo guardar la configuracion en el perfil del CAD."))
  )
  (princ)
)

(defun c:XFONDO ( / *error* config dark light dark-ole light-ole space
                    property display current target target-rgb target-ole
                    refreshed-display theme-result cursor-result applied)
  (defun *error* (message)
    (if (and message
             (/= message "Function cancelled")
             (/= message "quit / exit abort"))
      (prompt (strcat "\nError en XFondo: " message)))
    (princ)
  )

  (setq config (xfondo:load-config))
  (if (null config)
    (prompt
      "\nXFondo todavia no esta configurado. Ejecute XFondoConfig primero.")
    (progn
      (setq dark (car config)
            light (cadr config)
            dark-ole (xfondo:rgb-to-ole dark)
            light-ole (xfondo:rgb-to-ole light)
            space (xfondo:active-space)
            property
              (if (= space 'PAPER)
                'GraphicsWinLayoutBackgrndColor
                'GraphicsWinModelBackgrndColor)
            display (xfondo:get-display))

      (if (null display)
        (prompt
          "\nEste CAD no expone las preferencias de fondo mediante ActiveX.")
        (progn
          (setq current (xfondo:get-color-property display property))
          (cond
            ((null current)
              (prompt "\nNo se pudo leer el color de fondo actual en este CAD."))
            ((= current dark-ole) (setq target 'LIGHT))
            ((= current light-ole) (setq target 'DARK))
            (T (setq target (xfondo:choose-target)))
          )

          (if target
            (progn
              (if (= target 'DARK)
                (setq target-rgb dark target-ole dark-ole)
                (setq target-rgb light target-ole light-ole))

              (if (= space 'MODEL)
                (progn
                  ;; El tema cambia exclusivamente en Modelo.
                  (setq theme-result
                    (xfondo:set-ui-theme (if (= target 'DARK) 0 1)))
                  ;; Algunos CAD recrean Preferences al cambiar COLORTHEME.
                  ;; Si la nueva referencia aun no esta disponible, se conserva
                  ;; la anterior en lugar de perder una referencia valida.
                  (setq refreshed-display (xfondo:get-display))
                  (if refreshed-display (setq display refreshed-display))
                )
              )

              (if display
                (setq applied
                  (xfondo:put-color-property display property target-ole)))

              (if applied
                (progn
                  (if (= space 'MODEL)
                    (setq cursor-result
                      (xfondo:put-color-property
                        display
                        'ModelCrosshairColor
                        (xfondo:contrast-color target-rgb))))
                  (xfondo:regen)
                  (prompt
                    (strcat
                      "\nFondo "
                      (if (= target 'DARK) "oscuro" "claro")
                      " aplicado en "
                      (if (= space 'MODEL) "Modelo." "Papel.")))
                  (if (and (= space 'MODEL) (not theme-result))
                    (prompt "\nCOLORTHEME no esta disponible; el tema de interfaz no cambio."))
                  (if (and (= space 'MODEL) (not cursor-result))
                    (prompt "\nEl CAD no permitio ajustar el color del cursor."))
                )
                (prompt "\nEl CAD no permitio cambiar el fondo del espacio activo.")
              )
            )
          )
        )
      )
    )
  )
  (princ)
)

(princ "\nXFondo v4 cargado. Comandos: XFondo y XFondoConfig.")
(princ)